{-# LANGUAGE TemplateHaskellQuotes, LambdaCase, CPP, ScopedTypeVariables,
TupleSections, DeriveDataTypeable, DeriveGeneric #-}
module Language.Haskell.TH.Desugar.Core where
import Prelude hiding (mapM, foldl, foldr, all, elem, exp, concatMap, and)
import Language.Haskell.TH hiding (Extension(..), match, clause, cxt)
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH.Syntax hiding (Extension(..), lift)
import Control.Monad hiding (forM_, mapM)
import qualified Control.Monad.Fail as Fail
import Control.Monad.Trans (MonadTrans(..))
import Control.Monad.Writer (MonadWriter(..), WriterT(..))
import Control.Monad.Zip
import Data.Data (Data)
import Data.Either (lefts)
import Data.Foldable as F hiding (concat, notElem)
import qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe (isJust, mapMaybe)
import Data.Monoid (All(..))
import qualified Data.Set as S
import Data.Set (Set)
import Data.Traversable
#if __GLASGOW_HASKELL__ >= 803
import GHC.OverloadedLabels ( fromLabel )
#endif
#if __GLASGOW_HASKELL__ >= 807
import GHC.Classes (IP(..))
#else
import qualified Language.Haskell.TH as LangExt (Extension(..))
#endif
#if __GLASGOW_HASKELL__ >= 902
import Data.List.NonEmpty (NonEmpty(..))
import GHC.Records (HasField(..))
#endif
import GHC.Exts
import GHC.Generics (Generic)
import Language.Haskell.TH.Desugar.AST
import Language.Haskell.TH.Desugar.FV
import qualified Language.Haskell.TH.Desugar.OSet as OS
import Language.Haskell.TH.Desugar.OSet (OSet)
import Language.Haskell.TH.Desugar.Util
import Language.Haskell.TH.Desugar.Reify
dsExp :: DsMonad q => Exp -> q DExp
dsExp :: forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp (VarE Name
n) = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE Name
n
dsExp (ConE Name
n) = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DConE Name
n
dsExp (LitE Lit
lit) = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Lit -> DExp
DLitE Lit
lit
dsExp (AppE Exp
e1 Exp
e2) = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e1 q (DExp -> DExp) -> q DExp -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e2
dsExp (InfixE Maybe Exp
Nothing Exp
op Maybe Exp
Nothing) = Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op
dsExp (InfixE (Just Exp
lhs) Exp
op Maybe Exp
Nothing) = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op) q (DExp -> DExp) -> q DExp -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
lhs)
dsExp (InfixE Maybe Exp
Nothing Exp
op (Just Exp
rhs)) = do
Name
lhsName <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"lhs"
DExp
op' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op
DExp
rhs' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
rhs
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name
lhsName] ((DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE DExp
op' [Name -> DExp
DVarE Name
lhsName, DExp
rhs'])
dsExp (InfixE (Just Exp
lhs) Exp
op (Just Exp
rhs)) =
DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op q (DExp -> DExp) -> q DExp -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
lhs) q (DExp -> DExp) -> q DExp -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
rhs
dsExp (UInfixE Exp
_ Exp
_ Exp
_) =
String -> q DExp
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot desugar unresolved infix operators."
dsExp (ParensE Exp
exp) = Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsExp (LamE [Pat]
pats Exp
exp) = do
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
([DPat]
pats', DExp
exp'') <- [Pat] -> DExp -> q ([DPat], DExp)
forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp [Pat]
pats DExp
exp'
[DPat] -> DExp -> q DExp
forall (q :: * -> *). Quasi q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats [DPat]
pats' DExp
exp''
dsExp (LamCaseE [Match]
matches) = do
Name
x <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"x"
[DMatch]
matches' <- Name -> [Match] -> q [DMatch]
forall (q :: * -> *). DsMonad q => Name -> [Match] -> q [DMatch]
dsMatches Name
x [Match]
matches
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name
x] (DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
x) [DMatch]
matches')
dsExp (TupE [Maybe Exp]
exps) = (Int -> Name) -> [Maybe Exp] -> q DExp
forall (q :: * -> *).
DsMonad q =>
(Int -> Name) -> [Maybe Exp] -> q DExp
dsTup Int -> Name
tupleDataName [Maybe Exp]
exps
dsExp (UnboxedTupE [Maybe Exp]
exps) = (Int -> Name) -> [Maybe Exp] -> q DExp
forall (q :: * -> *).
DsMonad q =>
(Int -> Name) -> [Maybe Exp] -> q DExp
dsTup Int -> Name
unboxedTupleDataName [Maybe Exp]
exps
dsExp (CondE Exp
e1 Exp
e2 Exp
e3) =
Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp (Exp -> [Match] -> Exp
CaseE Exp
e1 [Name -> Exp -> Match
mkBoolMatch 'True Exp
e2, Name -> Exp -> Match
mkBoolMatch 'False Exp
e3])
where
mkBoolMatch :: Name -> Exp -> Match
mkBoolMatch :: Name -> Exp -> Match
mkBoolMatch Name
boolDataCon Exp
rhs =
Pat -> Body -> [Dec] -> Match
Match (Name -> [Type] -> [Pat] -> Pat
ConP Name
boolDataCon
#if __GLASGOW_HASKELL__ >= 901
[]
#endif
[]) (Exp -> Body
NormalB Exp
rhs) []
dsExp (MultiIfE [(Guard, Exp)]
guarded_exps) =
let failure :: DExp
failure = MatchContext -> DExp
mkErrorMatchExpr MatchContext
MultiWayIfAlt in
[(Guard, Exp)] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards [(Guard, Exp)]
guarded_exps DExp
failure
dsExp (LetE [Dec]
decs Exp
exp) = do
([DLetDec]
decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
exp'
dsExp (CaseE (VarE Name
scrutinee) [Match]
matches) = do
[DMatch]
matches' <- Name -> [Match] -> q [DMatch]
forall (q :: * -> *). DsMonad q => Name -> [Match] -> q [DMatch]
dsMatches Name
scrutinee [Match]
matches
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
scrutinee) [DMatch]
matches'
dsExp (CaseE Exp
exp [Match]
matches) = do
Name
scrutinee <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"scrutinee"
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
[DMatch]
matches' <- Name -> [Match] -> q [DMatch]
forall (q :: * -> *). DsMonad q => Name -> [Match] -> q [DMatch]
dsMatches Name
scrutinee [Match]
matches
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DPat -> DExp -> DLetDec
DValD (Name -> DPat
DVarP Name
scrutinee) DExp
exp'] (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$
DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
scrutinee) [DMatch]
matches'
#if __GLASGOW_HASKELL__ >= 900
dsExp (DoE Maybe ModName
mb_mod [Stmt]
stmts) = Maybe ModName -> [Stmt] -> q DExp
forall (q :: * -> *).
DsMonad q =>
Maybe ModName -> [Stmt] -> q DExp
dsDoStmts Maybe ModName
mb_mod [Stmt]
stmts
#else
dsExp (DoE stmts) = dsDoStmts Nothing stmts
#endif
dsExp (CompE [Stmt]
stmts) = [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
stmts
dsExp (ArithSeqE (FromR Exp
exp)) = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFrom) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsExp (ArithSeqE (FromThenR Exp
exp1 Exp
exp2)) =
DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFromThen) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp1) q (DExp -> DExp) -> q DExp -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp2
dsExp (ArithSeqE (FromToR Exp
exp1 Exp
exp2)) =
DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFromTo) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp1) q (DExp -> DExp) -> q DExp -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp2
dsExp (ArithSeqE (FromThenToR Exp
e1 Exp
e2 Exp
e3)) =
DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFromThenTo) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e1) q (DExp -> DExp) -> q DExp -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e2) q (DExp -> DExp) -> q DExp -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e3
dsExp (ListE [Exp]
exps) = [Exp] -> q DExp
forall {m :: * -> *}. DsMonad m => [Exp] -> m DExp
go [Exp]
exps
where go :: [Exp] -> m DExp
go [] = DExp -> m DExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> m DExp) -> DExp -> m DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DConE '[]
go (Exp
h : [Exp]
t) = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> m DExp -> m (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE '(:)) (DExp -> DExp) -> m DExp -> m DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> m DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
h) m (DExp -> DExp) -> m DExp -> m DExp
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Exp] -> m DExp
go [Exp]
t
dsExp (SigE Exp
exp Type
ty) = DExp -> DKind -> DExp
DSigE (DExp -> DKind -> DExp) -> q DExp -> q (DKind -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp q (DKind -> DExp) -> q DKind -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
dsExp (RecConE Name
con_name [FieldExp]
field_exps) = do
Con
con <- Name -> q Con
forall (q :: * -> *). DsMonad q => Name -> q Con
dataConNameToCon Name
con_name
[DExp]
reordered <- Con -> q [DExp]
forall {m :: * -> *}. DsMonad m => Con -> m [DExp]
reorder Con
con
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE Name
con_name) [DExp]
reordered
where
reorder :: Con -> m [DExp]
reorder Con
con = case Con
con of
NormalC Name
_name [BangType]
fields -> [BangType] -> m [DExp]
forall {m :: * -> *} {t :: * -> *} {a}.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType]
fields
InfixC BangType
field1 Name
_name BangType
field2 -> [BangType] -> m [DExp]
forall {m :: * -> *} {t :: * -> *} {a}.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType
field1, BangType
field2]
RecC Name
_name [VarBangType]
fields -> [VarBangType] -> m [DExp]
forall {q :: * -> *}. DsMonad q => [VarBangType] -> q [DExp]
reorder_fields [VarBangType]
fields
ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
c -> Con -> m [DExp]
reorder Con
c
GadtC [Name]
_names [BangType]
fields Type
_ret_ty -> [BangType] -> m [DExp]
forall {m :: * -> *} {t :: * -> *} {a}.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType]
fields
RecGadtC [Name]
_names [VarBangType]
fields Type
_ret_ty -> [VarBangType] -> m [DExp]
forall {q :: * -> *}. DsMonad q => [VarBangType] -> q [DExp]
reorder_fields [VarBangType]
fields
reorder_fields :: [VarBangType] -> q [DExp]
reorder_fields [VarBangType]
fields = Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
forall (q :: * -> *).
DsMonad q =>
Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
reorderFields Name
con_name [VarBangType]
fields [FieldExp]
field_exps
(DExp -> [DExp]
forall a. a -> [a]
repeat (DExp -> [DExp]) -> DExp -> [DExp]
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE 'undefined)
non_record :: t a -> m [DExp]
non_record t a
fields | [FieldExp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldExp]
field_exps
= [DExp] -> m [DExp]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DExp] -> m [DExp]) -> [DExp] -> m [DExp]
forall a b. (a -> b) -> a -> b
$ Int -> DExp -> [DExp]
forall a. Int -> a -> [a]
replicate (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
fields) (DExp -> [DExp]) -> DExp -> [DExp]
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE 'undefined
| Bool
otherwise =
String -> m [DExp]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> m [DExp]) -> String -> m [DExp]
forall a b. (a -> b) -> a -> b
$ String
"Record syntax used with non-record constructor "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name -> String
forall a. Show a => a -> String
show Name
con_name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
dsExp (RecUpdE Exp
exp [FieldExp]
field_exps) = do
Name
first_name <- case [FieldExp]
field_exps of
((Name
name, Exp
_) : [FieldExp]
_) -> Name -> q Name
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
[FieldExp]
_ -> String -> q Name
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Record update with no fields listed."
Info
info <- Name -> q Info
forall (q :: * -> *). DsMonad q => Name -> q Info
reifyWithLocals Name
first_name
Type
applied_type <- case Info
info of
VarI Name
_name Type
ty Maybe Dec
_m_dec -> Type -> q Type
forall (q :: * -> *). DsMonad q => Type -> q Type
extract_first_arg Type
ty
Info
_ -> String -> q Type
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Record update with an invalid field name."
Name
type_name <- Type -> q Name
forall (q :: * -> *). DsMonad q => Type -> q Name
extract_type_name Type
applied_type
(DataFlavor
_, [TyVarBndrUnit]
_, [Con]
cons) <- String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])
forall (q :: * -> *).
DsMonad q =>
String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])
getDataD String
"This seems to be an error in GHC." Name
type_name
let filtered_cons :: [Con]
filtered_cons = [Con] -> [Name] -> [Con]
forall {t :: * -> *}. Foldable t => [Con] -> t Name -> [Con]
filter_cons_with_names [Con]
cons ((FieldExp -> Name) -> [FieldExp] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldExp -> Name
forall a b. (a, b) -> a
fst [FieldExp]
field_exps)
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
[DMatch]
matches <- (Con -> q DMatch) -> [Con] -> q [DMatch]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Con -> q DMatch
forall (q :: * -> *). DsMonad q => Con -> q DMatch
con_to_dmatch [Con]
filtered_cons
let all_matches :: [DMatch]
all_matches
| [Con] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
filtered_cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Con] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
cons = [DMatch]
matches
| Bool
otherwise = [DMatch]
matches [DMatch] -> [DMatch] -> [DMatch]
forall a. [a] -> [a] -> [a]
++ [DMatch
error_match]
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
DCaseE DExp
exp' [DMatch]
all_matches
where
extract_first_arg :: DsMonad q => Type -> q Type
extract_first_arg :: forall (q :: * -> *). DsMonad q => Type -> q Type
extract_first_arg (AppT (AppT Type
ArrowT Type
arg) Type
_) = Type -> q Type
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
arg
extract_first_arg (ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
t) = Type -> q Type
forall (q :: * -> *). DsMonad q => Type -> q Type
extract_first_arg Type
t
extract_first_arg (SigT Type
t Type
_) = Type -> q Type
forall (q :: * -> *). DsMonad q => Type -> q Type
extract_first_arg Type
t
extract_first_arg Type
_ = String -> q Type
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Record selector not a function."
extract_type_name :: DsMonad q => Type -> q Name
extract_type_name :: forall (q :: * -> *). DsMonad q => Type -> q Name
extract_type_name (AppT Type
t1 Type
_) = Type -> q Name
forall (q :: * -> *). DsMonad q => Type -> q Name
extract_type_name Type
t1
extract_type_name (SigT Type
t Type
_) = Type -> q Name
forall (q :: * -> *). DsMonad q => Type -> q Name
extract_type_name Type
t
extract_type_name (ConT Name
n) = Name -> q Name
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
extract_type_name Type
_ = String -> q Name
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Record selector domain not a datatype."
filter_cons_with_names :: [Con] -> t Name -> [Con]
filter_cons_with_names [Con]
cons t Name
field_names =
(Con -> Bool) -> [Con] -> [Con]
forall a. (a -> Bool) -> [a] -> [a]
filter Con -> Bool
has_names [Con]
cons
where
args_contain_names :: [(Name, b, c)] -> Bool
args_contain_names [(Name, b, c)]
args =
let con_field_names :: [Name]
con_field_names = ((Name, b, c) -> Name) -> [(Name, b, c)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, b, c) -> Name
forall {a} {b} {c}. (a, b, c) -> a
fst_of_3 [(Name, b, c)]
args in
(Name -> Bool) -> t Name -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
con_field_names) t Name
field_names
has_names :: Con -> Bool
has_names (RecC Name
_con_name [VarBangType]
args) =
[VarBangType] -> Bool
forall {b} {c}. [(Name, b, c)] -> Bool
args_contain_names [VarBangType]
args
has_names (RecGadtC [Name]
_con_name [VarBangType]
args Type
_ret_ty) =
[VarBangType] -> Bool
forall {b} {c}. [(Name, b, c)] -> Bool
args_contain_names [VarBangType]
args
has_names (ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
c) = Con -> Bool
has_names Con
c
has_names Con
_ = Bool
False
rec_con_to_dmatch :: Name -> [VarBangType] -> m DMatch
rec_con_to_dmatch Name
con_name [VarBangType]
args = do
let con_field_names :: [Name]
con_field_names = (VarBangType -> Name) -> [VarBangType] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Name
forall {a} {b} {c}. (a, b, c) -> a
fst_of_3 [VarBangType]
args
[Name]
field_var_names <- (Name -> m Name) -> [Name] -> m [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> m Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName (String -> m Name) -> (Name -> String) -> Name -> m Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) [Name]
con_field_names
DPat -> DExp -> DMatch
DMatch (Name -> [DKind] -> [DPat] -> DPat
DConP Name
con_name [] ((Name -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
field_var_names)) (DExp -> DMatch) -> m DExp -> m DMatch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
((DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE Name
con_name) ([DExp] -> DExp) -> m [DExp] -> m DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(Name -> [VarBangType] -> [FieldExp] -> [DExp] -> m [DExp]
forall (q :: * -> *).
DsMonad q =>
Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
reorderFields Name
con_name [VarBangType]
args [FieldExp]
field_exps ((Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DVarE [Name]
field_var_names)))
con_to_dmatch :: DsMonad q => Con -> q DMatch
con_to_dmatch :: forall (q :: * -> *). DsMonad q => Con -> q DMatch
con_to_dmatch (RecC Name
con_name [VarBangType]
args) = Name -> [VarBangType] -> q DMatch
forall {m :: * -> *}.
DsMonad m =>
Name -> [VarBangType] -> m DMatch
rec_con_to_dmatch Name
con_name [VarBangType]
args
con_to_dmatch (RecGadtC [Name
con_name] [VarBangType]
args Type
_ret_ty) = Name -> [VarBangType] -> q DMatch
forall {m :: * -> *}.
DsMonad m =>
Name -> [VarBangType] -> m DMatch
rec_con_to_dmatch Name
con_name [VarBangType]
args
con_to_dmatch (ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
c) = Con -> q DMatch
forall (q :: * -> *). DsMonad q => Con -> q DMatch
con_to_dmatch Con
c
con_to_dmatch Con
_ = String -> q DMatch
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Internal error within th-desugar."
error_match :: DMatch
error_match = DPat -> DExp -> DMatch
DMatch DPat
DWildP (MatchContext -> DExp
mkErrorMatchExpr MatchContext
RecUpd)
fst_of_3 :: (a, b, c) -> a
fst_of_3 (a
x, b
_, c
_) = a
x
dsExp (StaticE Exp
exp) = DExp -> DExp
DStaticE (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsExp (UnboundVarE Name
n) = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> DExp
DVarE Name
n)
#if __GLASGOW_HASKELL__ >= 801
dsExp (AppTypeE Exp
exp Type
ty) = DExp -> DKind -> DExp
DAppTypeE (DExp -> DKind -> DExp) -> q DExp -> q (DKind -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp q (DKind -> DExp) -> q DKind -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
dsExp (UnboxedSumE Exp
exp Int
alt Int
arity) =
DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE (Name -> DExp) -> Name -> DExp
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Name
unboxedSumDataName Int
alt Int
arity) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
#endif
#if __GLASGOW_HASKELL__ >= 803
dsExp (LabelE String
str) = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE 'fromLabel DExp -> DKind -> DExp
`DAppTypeE` TyLit -> DKind
DLitT (String -> TyLit
StrTyLit String
str)
#endif
#if __GLASGOW_HASKELL__ >= 807
dsExp (ImplicitParamVarE String
n) = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE 'ip DExp -> DKind -> DExp
`DAppTypeE` TyLit -> DKind
DLitT (String -> TyLit
StrTyLit String
n)
dsExp (MDoE {}) = String -> q DExp
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"th-desugar currently does not support RecursiveDo"
#endif
#if __GLASGOW_HASKELL__ >= 902
dsExp (GetFieldE Exp
arg String
field) = DExp -> DExp -> DExp
DAppE (String -> DExp
mkGetFieldProj String
field) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
arg
dsExp (ProjectionE NonEmpty String
fields) =
case NonEmpty String
fields of
String
f :| [String]
fs -> DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ (DExp -> String -> DExp) -> DExp -> [String] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DExp -> String -> DExp
comp (String -> DExp
mkGetFieldProj String
f) [String]
fs
where
comp :: DExp -> String -> DExp
comp :: DExp -> String -> DExp
comp DExp
acc String
f = Name -> DExp
DVarE '(.) DExp -> DExp -> DExp
`DAppE` String -> DExp
mkGetFieldProj String
f DExp -> DExp -> DExp
`DAppE` DExp
acc
#endif
#if __GLASGOW_HASKELL__ >= 903
dsExp (LamCasesE [Clause]
clauses) = do
[DClause]
clauses' <- MatchContext -> [Clause] -> q [DClause]
forall (q :: * -> *).
DsMonad q =>
MatchContext -> [Clause] -> q [DClause]
dsClauses MatchContext
CaseAlt [Clause]
clauses
Int
numArgs <-
case [DClause]
clauses' of
(DClause [DPat]
pats DExp
_:[DClause]
_) -> Int -> q Int
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> q Int) -> Int -> q Int
forall a b. (a -> b) -> a -> b
$ [DPat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DPat]
pats
[] -> String -> q Int
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"\\cases expression must have at least one alternative"
[Name]
args <- Int -> q Name -> q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numArgs (String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"x")
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name]
args (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
DCaseE ([DExp] -> DExp
mkUnboxedTupleDExp ((Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DVarE [Name]
args))
((DClause -> DMatch) -> [DClause] -> [DMatch]
forall a b. (a -> b) -> [a] -> [b]
map DClause -> DMatch
dClauseToUnboxedTupleMatch [DClause]
clauses')
#endif
dClauseToUnboxedTupleMatch :: DClause -> DMatch
dClauseToUnboxedTupleMatch :: DClause -> DMatch
dClauseToUnboxedTupleMatch (DClause [DPat]
pats DExp
rhs) =
DPat -> DExp -> DMatch
DMatch ([DPat] -> DPat
mkUnboxedTupleDPat [DPat]
pats) DExp
rhs
#if __GLASGOW_HASKELL__ >= 809
dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp
dsTup :: forall (q :: * -> *).
DsMonad q =>
(Int -> Name) -> [Maybe Exp] -> q DExp
dsTup = (Int -> Name) -> [Maybe Exp] -> q DExp
forall (q :: * -> *).
DsMonad q =>
(Int -> Name) -> [Maybe Exp] -> q DExp
ds_tup
#else
dsTup :: DsMonad q => (Int -> Name) -> [Exp] -> q DExp
dsTup tuple_data_name = ds_tup tuple_data_name . map Just
#endif
ds_tup :: forall q. DsMonad q
=> (Int -> Name)
-> [Maybe Exp]
-> q DExp
ds_tup :: forall (q :: * -> *).
DsMonad q =>
(Int -> Name) -> [Maybe Exp] -> q DExp
ds_tup Int -> Name
tuple_data_name [Maybe Exp]
mb_exps = do
[Either Name DExp]
section_exps <- (Maybe Exp -> q (Either Name DExp))
-> [Maybe Exp] -> q [Either Name DExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Maybe Exp -> q (Either Name DExp)
ds_section_exp [Maybe Exp]
mb_exps
let section_vars :: [Name]
section_vars = [Either Name DExp] -> [Name]
forall a b. [Either a b] -> [a]
lefts [Either Name DExp]
section_exps
tup_body :: DExp
tup_body = [Either Name DExp] -> DExp
mk_tup_body [Either Name DExp]
section_exps
if [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
section_vars
then DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
tup_body
else [DPat] -> DExp -> q DExp
forall (q :: * -> *). Quasi q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats ((Name -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
section_vars) DExp
tup_body
where
ds_section_exp :: Maybe Exp -> q (Either Name DExp)
ds_section_exp :: Maybe Exp -> q (Either Name DExp)
ds_section_exp = q (Either Name DExp)
-> (Exp -> q (Either Name DExp))
-> Maybe Exp
-> q (Either Name DExp)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> Either Name DExp
forall a b. a -> Either a b
Left (Name -> Either Name DExp) -> q Name -> q (Either Name DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
qNewName String
"ts") ((DExp -> Either Name DExp) -> q DExp -> q (Either Name DExp)
forall a b. (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DExp -> Either Name DExp
forall a b. b -> Either a b
Right (q DExp -> q (Either Name DExp))
-> (Exp -> q DExp) -> Exp -> q (Either Name DExp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp)
mk_tup_body :: [Either Name DExp] -> DExp
mk_tup_body :: [Either Name DExp] -> DExp
mk_tup_body [Either Name DExp]
section_exps =
(DExp -> Either Name DExp -> DExp)
-> DExp -> [Either Name DExp] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DExp -> Either Name DExp -> DExp
apply_tup_body (Name -> DExp
DConE (Name -> DExp) -> Name -> DExp
forall a b. (a -> b) -> a -> b
$ Int -> Name
tuple_data_name ([Either Name DExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Name DExp]
section_exps))
[Either Name DExp]
section_exps
apply_tup_body :: DExp -> Either Name DExp -> DExp
apply_tup_body :: DExp -> Either Name DExp -> DExp
apply_tup_body DExp
f (Left Name
n) = DExp
f DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
n
apply_tup_body DExp
f (Right DExp
e) = DExp
f DExp -> DExp -> DExp
`DAppE` DExp
e
mkDLamEFromDPats :: Quasi q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats :: forall (q :: * -> *). Quasi q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats [DPat]
pats DExp
exp
| Just [Name]
names <- (DPat -> Maybe Name) -> [DPat] -> Maybe [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DPat -> Maybe Name
stripDVarP_maybe [DPat]
pats
= DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name]
names DExp
exp
| Bool
otherwise
= do [Name]
arg_names <- Int -> q Name -> q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([DPat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DPat]
pats) (String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"arg")
let scrutinee :: DExp
scrutinee = [DExp] -> DExp
mkUnboxedTupleDExp ((Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DVarE [Name]
arg_names)
match :: DMatch
match = DPat -> DExp -> DMatch
DMatch ([DPat] -> DPat
mkUnboxedTupleDPat [DPat]
pats) DExp
exp
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name]
arg_names (DExp -> [DMatch] -> DExp
DCaseE DExp
scrutinee [DMatch
match])
where
stripDVarP_maybe :: DPat -> Maybe Name
stripDVarP_maybe :: DPat -> Maybe Name
stripDVarP_maybe (DVarP Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
stripDVarP_maybe DPat
_ = Maybe Name
forall a. Maybe a
Nothing
#if __GLASGOW_HASKELL__ >= 902
mkGetFieldProj :: String -> DExp
mkGetFieldProj :: String -> DExp
mkGetFieldProj String
field = Name -> DExp
DVarE 'getField DExp -> DKind -> DExp
`DAppTypeE` TyLit -> DKind
DLitT (String -> TyLit
StrTyLit String
field)
#endif
dsMatches :: DsMonad q
=> Name
-> [Match]
-> q [DMatch]
dsMatches :: forall (q :: * -> *). DsMonad q => Name -> [Match] -> q [DMatch]
dsMatches Name
scr = [Match] -> q [DMatch]
forall (q :: * -> *). DsMonad q => [Match] -> q [DMatch]
go
where
go :: DsMonad q => [Match] -> q [DMatch]
go :: forall (q :: * -> *). DsMonad q => [Match] -> q [DMatch]
go [] = [DMatch] -> q [DMatch]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
go (Match Pat
pat Body
body [Dec]
where_decs : [Match]
rest) = do
[DMatch]
rest' <- [Match] -> q [DMatch]
forall (q :: * -> *). DsMonad q => [Match] -> q [DMatch]
go [Match]
rest
let failure :: DExp
failure = MatchContext -> DExp -> [DMatch] -> DExp
maybeDCaseE MatchContext
CaseAlt (Name -> DExp
DVarE Name
scr) [DMatch]
rest'
DExp
exp' <- Body -> [Dec] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody Body
body [Dec]
where_decs DExp
failure
(DPat
pat', DExp
exp'') <- Pat -> DExp -> q (DPat, DExp)
forall (q :: * -> *). DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp Pat
pat DExp
exp'
Bool
uni_pattern <- DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
pat'
if Bool
uni_pattern
then [DMatch] -> q [DMatch]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [DPat -> DExp -> DMatch
DMatch DPat
pat' DExp
exp'']
else [DMatch] -> q [DMatch]
forall a. a -> q a
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')
dsBody :: DsMonad q
=> Body
-> [Dec]
-> DExp
-> q DExp
dsBody :: forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody (NormalB Exp
exp) [Dec]
decs DExp
_ = do
([DLetDec]
decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
exp'
dsBody (GuardedB [(Guard, Exp)]
guarded_exps) [Dec]
decs DExp
failure = do
([DLetDec]
decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
DExp
guarded_exp' <- [(Guard, Exp)] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards [(Guard, Exp)]
guarded_exps DExp
failure
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
guarded_exp'
maybeDLetE :: [DLetDec] -> DExp -> DExp
maybeDLetE :: [DLetDec] -> DExp -> DExp
maybeDLetE [] DExp
exp = DExp
exp
maybeDLetE [DLetDec]
decs DExp
exp = [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs DExp
exp
maybeDCaseE :: MatchContext -> DExp -> [DMatch] -> DExp
maybeDCaseE :: MatchContext -> DExp -> [DMatch] -> DExp
maybeDCaseE MatchContext
mc DExp
_ [] = MatchContext -> DExp
mkErrorMatchExpr MatchContext
mc
maybeDCaseE MatchContext
_ DExp
scrut [DMatch]
matches = DExp -> [DMatch] -> DExp
DCaseE DExp
scrut [DMatch]
matches
dsGuards :: DsMonad q
=> [(Guard, Exp)]
-> DExp
-> q DExp
dsGuards :: forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards [] DExp
thing_inside = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
thing_inside
dsGuards ((NormalG Exp
gd, Exp
exp) : [(Guard, Exp)]
rest) DExp
thing_inside =
[(Guard, Exp)] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards (([Stmt] -> Guard
PatG [Exp -> Stmt
NoBindS Exp
gd], Exp
exp) (Guard, Exp) -> [(Guard, Exp)] -> [(Guard, Exp)]
forall a. a -> [a] -> [a]
: [(Guard, Exp)]
rest) DExp
thing_inside
dsGuards ((PatG [Stmt]
stmts, Exp
exp) : [(Guard, Exp)]
rest) DExp
thing_inside = do
DExp
success <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
DExp
failure <- [(Guard, Exp)] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards [(Guard, Exp)]
rest DExp
thing_inside
[Stmt] -> DExp -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [Stmt]
stmts DExp
success DExp
failure
dsGuardStmts :: DsMonad q
=> [Stmt]
-> DExp
-> DExp
-> q DExp
dsGuardStmts :: forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [] DExp
success DExp
_failure = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
success
dsGuardStmts (BindS Pat
pat Exp
exp : [Stmt]
rest) DExp
success DExp
failure = do
DExp
success' <- [Stmt] -> DExp -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [Stmt]
rest DExp
success DExp
failure
(DPat
pat', DExp
success'') <- Pat -> DExp -> q (DPat, DExp)
forall (q :: * -> *). DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp Pat
pat DExp
success'
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
DCaseE DExp
exp' [DPat -> DExp -> DMatch
DMatch DPat
pat' DExp
success'', DPat -> DExp -> DMatch
DMatch DPat
DWildP DExp
failure]
dsGuardStmts (LetS [Dec]
decs : [Stmt]
rest) DExp
success DExp
failure = do
([DLetDec]
decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
DExp
success' <- [Stmt] -> DExp -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [Stmt]
rest DExp
success DExp
failure
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
success'
dsGuardStmts [NoBindS Exp
exp] DExp
success DExp
_failure
| VarE Name
name <- Exp
exp
, Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'otherwise
= DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
success
| ConE Name
name <- Exp
exp
, Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'True
= DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
success
dsGuardStmts (NoBindS Exp
exp : [Stmt]
rest) DExp
success DExp
failure = do
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
DExp
success' <- [Stmt] -> DExp -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [Stmt]
rest DExp
success DExp
failure
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
DCaseE DExp
exp' [ DPat -> DExp -> DMatch
DMatch (Name -> [DKind] -> [DPat] -> DPat
DConP 'True [] []) DExp
success'
, DPat -> DExp -> DMatch
DMatch (Name -> [DKind] -> [DPat] -> DPat
DConP 'False [] []) DExp
failure ]
dsGuardStmts (ParS [[Stmt]]
_ : [Stmt]
_) DExp
_ DExp
_ = String -> q DExp
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Parallel comprehension in a pattern guard."
#if __GLASGOW_HASKELL__ >= 807
dsGuardStmts (RecS {} : [Stmt]
_) DExp
_ DExp
_ = String -> q DExp
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"th-desugar currently does not support RecursiveDo"
#endif
dsDoStmts :: forall q. DsMonad q => Maybe ModName -> [Stmt] -> q DExp
dsDoStmts :: forall (q :: * -> *).
DsMonad q =>
Maybe ModName -> [Stmt] -> q DExp
dsDoStmts Maybe ModName
mb_mod = [Stmt] -> q DExp
go
where
go :: [Stmt] -> q DExp
go :: [Stmt] -> q DExp
go [] = String -> q DExp
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"do-expression ended with something other than bare statement."
go [NoBindS Exp
exp] = Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
go (BindS Pat
pat Exp
exp : [Stmt]
rest) = do
DExp
rest' <- [Stmt] -> q DExp
go [Stmt]
rest
Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp
forall (q :: * -> *).
DsMonad q =>
Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp
dsBindS Maybe ModName
mb_mod Exp
exp Pat
pat DExp
rest' String
"do expression"
go (LetS [Dec]
decs : [Stmt]
rest) = do
([DLetDec]
decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
DExp
rest' <- [Stmt] -> q DExp
go [Stmt]
rest
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
rest'
go (NoBindS Exp
exp : [Stmt]
rest) = do
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
DExp
rest' <- [Stmt] -> q DExp
go [Stmt]
rest
let sequence_name :: Name
sequence_name = Maybe ModName -> Name -> Name
mk_qual_do_name Maybe ModName
mb_mod '(>>)
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE Name
sequence_name) DExp
exp') DExp
rest'
go (ParS [[Stmt]]
_ : [Stmt]
_) = String -> q DExp
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Parallel comprehension in a do-statement."
#if __GLASGOW_HASKELL__ >= 807
go (RecS {} : [Stmt]
_) = String -> q DExp
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"th-desugar currently does not support RecursiveDo"
#endif
dsComp :: DsMonad q => [Stmt] -> q DExp
dsComp :: forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [] = String -> q DExp
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"List/monad comprehension ended with something other than a bare statement."
dsComp [NoBindS Exp
exp] = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'return) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsComp (BindS Pat
pat Exp
exp : [Stmt]
rest) = do
DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp
forall (q :: * -> *).
DsMonad q =>
Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp
dsBindS Maybe ModName
forall a. Maybe a
Nothing Exp
exp Pat
pat DExp
rest' String
"monad comprehension"
dsComp (LetS [Dec]
decs : [Stmt]
rest) = do
([DLetDec]
decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
rest'
dsComp (NoBindS Exp
exp : [Stmt]
rest) = do
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE '(>>)) (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'guard) DExp
exp')) DExp
rest'
dsComp (ParS [[Stmt]]
stmtss : [Stmt]
rest) = do
(DPat
pat, DExp
exp) <- [[Stmt]] -> q (DPat, DExp)
forall (q :: * -> *). DsMonad q => [[Stmt]] -> q (DPat, DExp)
dsParComp [[Stmt]]
stmtss
DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE '(>>=)) DExp
exp) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DPat] -> DExp -> q DExp
forall (q :: * -> *). Quasi q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats [DPat
pat] DExp
rest'
#if __GLASGOW_HASKELL__ >= 807
dsComp (RecS {} : [Stmt]
_) = String -> q DExp
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"th-desugar currently does not support RecursiveDo"
#endif
dsBindS :: forall q. DsMonad q
=> Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp
dsBindS :: forall (q :: * -> *).
DsMonad q =>
Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp
dsBindS Maybe ModName
mb_mod Exp
bind_arg_exp Pat
success_pat DExp
success_exp String
ctxt = do
DExp
bind_arg_exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
bind_arg_exp
(DPat
success_pat', DExp
success_exp') <- Pat -> DExp -> q (DPat, DExp)
forall (q :: * -> *). DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp Pat
success_pat DExp
success_exp
Bool
is_univ_pat <- DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
success_pat'
let bind_into :: DExp -> DExp
bind_into = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE Name
bind_name) DExp
bind_arg_exp')
if Bool
is_univ_pat
then DExp -> DExp
bind_into (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DPat] -> DExp -> q DExp
forall (q :: * -> *). Quasi q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats [DPat
success_pat'] DExp
success_exp'
else do Name
arg_name <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"arg"
Name
fail_name <- q Name
mk_fail_name
DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
bind_into (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name
arg_name] (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
arg_name)
[ DPat -> DExp -> DMatch
DMatch DPat
success_pat' DExp
success_exp'
, DPat -> DExp -> DMatch
DMatch DPat
DWildP (DExp -> DMatch) -> DExp -> DMatch
forall a b. (a -> b) -> a -> b
$
Name -> DExp
DVarE Name
fail_name DExp -> DExp -> DExp
`DAppE`
Lit -> DExp
DLitE (String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ String
"Pattern match failure in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ctxt)
]
where
bind_name :: Name
bind_name = Maybe ModName -> Name -> Name
mk_qual_do_name Maybe ModName
mb_mod '(>>=)
mk_fail_name :: q Name
#if __GLASGOW_HASKELL__ >= 807
mk_fail_name :: q Name
mk_fail_name = Name -> q Name
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
fail_MonadFail_name
#else
mk_fail_name = do
mfd <- qIsExtEnabled LangExt.MonadFailDesugaring
return $ if mfd then fail_MonadFail_name else fail_Prelude_name
#endif
fail_MonadFail_name :: Name
fail_MonadFail_name = Maybe ModName -> Name -> Name
mk_qual_do_name Maybe ModName
mb_mod 'Fail.fail
#if __GLASGOW_HASKELL__ < 807
fail_Prelude_name = mk_qual_do_name mb_mod 'Prelude.fail
#endif
dsParComp :: DsMonad q => [[Stmt]] -> q (DPat, DExp)
dsParComp :: forall (q :: * -> *). DsMonad q => [[Stmt]] -> q (DPat, DExp)
dsParComp [] = String -> q (DPat, DExp)
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Empty list of parallel comprehension statements."
dsParComp [[Stmt]
r] = do
let rv :: OSet Name
rv = (Stmt -> OSet Name) -> [Stmt] -> OSet Name
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Stmt -> OSet Name
extractBoundNamesStmt [Stmt]
r
DExp
dsR <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp ([Stmt]
r [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [OSet Name -> Stmt
mk_tuple_stmt OSet Name
rv])
(DPat, DExp) -> q (DPat, DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (OSet Name -> DPat
mk_tuple_dpat OSet Name
rv, DExp
dsR)
dsParComp ([Stmt]
q : [[Stmt]]
rest) = do
let qv :: OSet Name
qv = (Stmt -> OSet Name) -> [Stmt] -> OSet Name
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Stmt -> OSet Name
extractBoundNamesStmt [Stmt]
q
(DPat
rest_pat, DExp
rest_exp) <- [[Stmt]] -> q (DPat, DExp)
forall (q :: * -> *). DsMonad q => [[Stmt]] -> q (DPat, DExp)
dsParComp [[Stmt]]
rest
DExp
dsQ <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp ([Stmt]
q [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [OSet Name -> Stmt
mk_tuple_stmt OSet Name
qv])
let zipped :: DExp
zipped = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'mzip) DExp
dsQ) DExp
rest_exp
(DPat, DExp) -> q (DPat, DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [DKind] -> [DPat] -> DPat
DConP (Int -> Name
tupleDataName Int
2) [] [OSet Name -> DPat
mk_tuple_dpat OSet Name
qv, DPat
rest_pat], DExp
zipped)
mk_tuple_stmt :: OSet Name -> Stmt
mk_tuple_stmt :: OSet Name -> Stmt
mk_tuple_stmt OSet Name
name_set =
Exp -> Stmt
NoBindS ([Exp] -> Exp
mkTupleExp ((Name -> [Exp] -> [Exp]) -> [Exp] -> OSet Name -> [Exp]
forall a b. (a -> b -> b) -> b -> OSet a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr ((:) (Exp -> [Exp] -> [Exp]) -> (Name -> Exp) -> Name -> [Exp] -> [Exp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) [] OSet Name
name_set))
mk_tuple_dpat :: OSet Name -> DPat
mk_tuple_dpat :: OSet Name -> DPat
mk_tuple_dpat OSet Name
name_set =
[DPat] -> DPat
mkTupleDPat ((Name -> [DPat] -> [DPat]) -> [DPat] -> OSet Name -> [DPat]
forall a b. (a -> b -> b) -> b -> OSet a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr ((:) (DPat -> [DPat] -> [DPat])
-> (Name -> DPat) -> Name -> [DPat] -> [DPat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DPat
DVarP) [] OSet Name
name_set)
dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp :: forall (q :: * -> *). DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp Pat
pat DExp
exp = do
(DPat
pat', [(Name, DExp)]
vars) <- WriterT [(Name, DExp)] q DPat -> q (DPat, [(Name, DExp)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [(Name, DExp)] q DPat -> q (DPat, [(Name, DExp)]))
-> WriterT [(Name, DExp)] q DPat -> q (DPat, [(Name, DExp)])
forall a b. (a -> b) -> a -> b
$ Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
let name_decs :: [DLetDec]
name_decs = ((Name, DExp) -> DLetDec) -> [(Name, DExp)] -> [DLetDec]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> DExp -> DLetDec) -> (Name, DExp) -> DLetDec
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (DPat -> DExp -> DLetDec
DValD (DPat -> DExp -> DLetDec)
-> (Name -> DPat) -> Name -> DExp -> DLetDec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DPat
DVarP)) [(Name, DExp)]
vars
(DPat, DExp) -> q (DPat, DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat
pat', [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
name_decs DExp
exp)
dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp :: forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp [Pat]
pats DExp
exp = do
([DPat]
pats', [(Name, DExp)]
vars) <- WriterT [(Name, DExp)] q [DPat] -> q ([DPat], [(Name, DExp)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [(Name, DExp)] q [DPat] -> q ([DPat], [(Name, DExp)]))
-> WriterT [(Name, DExp)] q [DPat] -> q ([DPat], [(Name, DExp)])
forall a b. (a -> b) -> a -> b
$ (Pat -> WriterT [(Name, DExp)] q DPat)
-> [Pat] -> WriterT [(Name, DExp)] q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat]
pats
let name_decs :: [DLetDec]
name_decs = ((Name, DExp) -> DLetDec) -> [(Name, DExp)] -> [DLetDec]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> DExp -> DLetDec) -> (Name, DExp) -> DLetDec
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (DPat -> DExp -> DLetDec
DValD (DPat -> DExp -> DLetDec)
-> (Name -> DPat) -> Name -> DExp -> DLetDec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DPat
DVarP)) [(Name, DExp)]
vars
([DPat], DExp) -> q ([DPat], DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DPat]
pats', [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
name_decs DExp
exp)
dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)])
dsPatX :: forall (q :: * -> *). DsMonad q => Pat -> q (DPat, [(Name, DExp)])
dsPatX = WriterT [(Name, DExp)] q DPat -> q (DPat, [(Name, DExp)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [(Name, DExp)] q DPat -> q (DPat, [(Name, DExp)]))
-> (Pat -> WriterT [(Name, DExp)] q DPat)
-> Pat
-> q (DPat, [(Name, DExp)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat
type PatM q = WriterT [(Name, DExp)] q
dsPat :: DsMonad q => Pat -> PatM q DPat
dsPat :: forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat (LitP Lit
lit) = DPat -> WriterT [(Name, DExp)] q DPat
forall a. a -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> WriterT [(Name, DExp)] q DPat)
-> DPat -> WriterT [(Name, DExp)] q DPat
forall a b. (a -> b) -> a -> b
$ Lit -> DPat
DLitP Lit
lit
dsPat (VarP Name
n) = DPat -> WriterT [(Name, DExp)] q DPat
forall a. a -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> WriterT [(Name, DExp)] q DPat)
-> DPat -> WriterT [(Name, DExp)] q DPat
forall a b. (a -> b) -> a -> b
$ Name -> DPat
DVarP Name
n
dsPat (TupP [Pat]
pats) = Name -> [DKind] -> [DPat] -> DPat
DConP (Int -> Name
tupleDataName ([Pat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
pats)) [] ([DPat] -> DPat)
-> WriterT [(Name, DExp)] q [DPat] -> WriterT [(Name, DExp)] q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat -> WriterT [(Name, DExp)] q DPat)
-> [Pat] -> WriterT [(Name, DExp)] q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat]
pats
dsPat (UnboxedTupP [Pat]
pats) = Name -> [DKind] -> [DPat] -> DPat
DConP (Int -> Name
unboxedTupleDataName ([Pat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
pats)) [] ([DPat] -> DPat)
-> WriterT [(Name, DExp)] q [DPat] -> WriterT [(Name, DExp)] q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(Pat -> WriterT [(Name, DExp)] q DPat)
-> [Pat] -> WriterT [(Name, DExp)] q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat]
pats
#if __GLASGOW_HASKELL__ >= 901
dsPat (ConP Name
name [Type]
tys [Pat]
pats) = Name -> [DKind] -> [DPat] -> DPat
DConP Name
name ([DKind] -> [DPat] -> DPat)
-> WriterT [(Name, DExp)] q [DKind]
-> WriterT [(Name, DExp)] q ([DPat] -> DPat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> WriterT [(Name, DExp)] q DKind)
-> [Type] -> WriterT [(Name, DExp)] q [DKind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> WriterT [(Name, DExp)] q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType [Type]
tys WriterT [(Name, DExp)] q ([DPat] -> DPat)
-> WriterT [(Name, DExp)] q [DPat] -> WriterT [(Name, DExp)] q DPat
forall a b.
WriterT [(Name, DExp)] q (a -> b)
-> WriterT [(Name, DExp)] q a -> WriterT [(Name, DExp)] q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pat -> WriterT [(Name, DExp)] q DPat)
-> [Pat] -> WriterT [(Name, DExp)] q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat]
pats
#else
dsPat (ConP name pats) = DConP name [] <$> mapM dsPat pats
#endif
dsPat (InfixP Pat
p1 Name
name Pat
p2) = Name -> [DKind] -> [DPat] -> DPat
DConP Name
name [] ([DPat] -> DPat)
-> WriterT [(Name, DExp)] q [DPat] -> WriterT [(Name, DExp)] q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat -> WriterT [(Name, DExp)] q DPat)
-> [Pat] -> WriterT [(Name, DExp)] q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat
p1, Pat
p2]
dsPat (UInfixP Pat
_ Name
_ Pat
_) =
String -> WriterT [(Name, DExp)] q DPat
forall a. String -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot desugar unresolved infix operators."
dsPat (ParensP Pat
pat) = Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
dsPat (TildeP Pat
pat) = DPat -> DPat
DTildeP (DPat -> DPat)
-> WriterT [(Name, DExp)] q DPat -> WriterT [(Name, DExp)] q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
dsPat (BangP Pat
pat) = DPat -> DPat
DBangP (DPat -> DPat)
-> WriterT [(Name, DExp)] q DPat -> WriterT [(Name, DExp)] q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
dsPat (AsP Name
name Pat
pat) = do
DPat
pat' <- Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
DPat
pat'' <- q DPat -> WriterT [(Name, DExp)] q DPat
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [(Name, DExp)] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q DPat -> WriterT [(Name, DExp)] q DPat)
-> q DPat -> WriterT [(Name, DExp)] q DPat
forall a b. (a -> b) -> a -> b
$ DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat'
[(Name, DExp)] -> WriterT [(Name, DExp)] q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(Name
name, DPat -> DExp
dPatToDExp DPat
pat'')]
DPat -> WriterT [(Name, DExp)] q DPat
forall a. a -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
pat''
dsPat Pat
WildP = DPat -> WriterT [(Name, DExp)] q DPat
forall a. a -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
DWildP
dsPat (RecP Name
con_name [FieldPat]
field_pats) = do
Con
con <- q Con -> WriterT [(Name, DExp)] q Con
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [(Name, DExp)] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q Con -> WriterT [(Name, DExp)] q Con)
-> q Con -> WriterT [(Name, DExp)] q Con
forall a b. (a -> b) -> a -> b
$ Name -> q Con
forall (q :: * -> *). DsMonad q => Name -> q Con
dataConNameToCon Name
con_name
[DPat]
reordered <- Con -> WriterT [(Name, DExp)] q [DPat]
forall {m :: * -> *}.
DsMonad m =>
Con -> WriterT [(Name, DExp)] m [DPat]
reorder Con
con
DPat -> WriterT [(Name, DExp)] q DPat
forall a. a -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> WriterT [(Name, DExp)] q DPat)
-> DPat -> WriterT [(Name, DExp)] q DPat
forall a b. (a -> b) -> a -> b
$ Name -> [DKind] -> [DPat] -> DPat
DConP Name
con_name [] [DPat]
reordered
where
reorder :: Con -> WriterT [(Name, DExp)] m [DPat]
reorder Con
con = case Con
con of
NormalC Name
_name [BangType]
fields -> [BangType] -> WriterT [(Name, DExp)] m [DPat]
forall {t :: * -> *} {t :: (* -> *) -> * -> *} {m :: * -> *} {a}.
(Foldable t, MonadTrans t, Monad (t m), MonadFail m) =>
t a -> t m [DPat]
non_record [BangType]
fields
InfixC BangType
field1 Name
_name BangType
field2 -> [BangType] -> WriterT [(Name, DExp)] m [DPat]
forall {t :: * -> *} {t :: (* -> *) -> * -> *} {m :: * -> *} {a}.
(Foldable t, MonadTrans t, Monad (t m), MonadFail m) =>
t a -> t m [DPat]
non_record [BangType
field1, BangType
field2]
RecC Name
_name [VarBangType]
fields -> [VarBangType] -> WriterT [(Name, DExp)] m [DPat]
forall {q :: * -> *}. DsMonad q => [VarBangType] -> PatM q [DPat]
reorder_fields_pat [VarBangType]
fields
ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
c -> Con -> WriterT [(Name, DExp)] m [DPat]
reorder Con
c
GadtC [Name]
_names [BangType]
fields Type
_ret_ty -> [BangType] -> WriterT [(Name, DExp)] m [DPat]
forall {t :: * -> *} {t :: (* -> *) -> * -> *} {m :: * -> *} {a}.
(Foldable t, MonadTrans t, Monad (t m), MonadFail m) =>
t a -> t m [DPat]
non_record [BangType]
fields
RecGadtC [Name]
_names [VarBangType]
fields Type
_ret_ty -> [VarBangType] -> WriterT [(Name, DExp)] m [DPat]
forall {q :: * -> *}. DsMonad q => [VarBangType] -> PatM q [DPat]
reorder_fields_pat [VarBangType]
fields
reorder_fields_pat :: [VarBangType] -> PatM q [DPat]
reorder_fields_pat [VarBangType]
fields = Name -> [VarBangType] -> [FieldPat] -> PatM q [DPat]
forall (q :: * -> *).
DsMonad q =>
Name -> [VarBangType] -> [FieldPat] -> PatM q [DPat]
reorderFieldsPat Name
con_name [VarBangType]
fields [FieldPat]
field_pats
non_record :: t a -> t m [DPat]
non_record t a
fields | [FieldPat] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldPat]
field_pats
= [DPat] -> t m [DPat]
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DPat] -> t m [DPat]) -> [DPat] -> t m [DPat]
forall a b. (a -> b) -> a -> b
$ Int -> DPat -> [DPat]
forall a. Int -> a -> [a]
replicate (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
fields) DPat
DWildP
| Bool
otherwise = m [DPat] -> t m [DPat]
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [DPat] -> t m [DPat]) -> m [DPat] -> t m [DPat]
forall a b. (a -> b) -> a -> b
$ String -> m [DPat]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible
(String -> m [DPat]) -> String -> m [DPat]
forall a b. (a -> b) -> a -> b
$ String
"Record syntax used with non-record constructor "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name -> String
forall a. Show a => a -> String
show Name
con_name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
dsPat (ListP [Pat]
pats) = [Pat] -> WriterT [(Name, DExp)] q DPat
forall {q :: * -> *}.
DsMonad q =>
[Pat] -> WriterT [(Name, DExp)] q DPat
go [Pat]
pats
where go :: [Pat] -> WriterT [(Name, DExp)] q DPat
go [] = DPat -> WriterT [(Name, DExp)] q DPat
forall a. a -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> WriterT [(Name, DExp)] q DPat)
-> DPat -> WriterT [(Name, DExp)] q DPat
forall a b. (a -> b) -> a -> b
$ Name -> [DKind] -> [DPat] -> DPat
DConP '[] [] []
go (Pat
h : [Pat]
t) = do
DPat
h' <- Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
h
DPat
t' <- [Pat] -> WriterT [(Name, DExp)] q DPat
go [Pat]
t
DPat -> WriterT [(Name, DExp)] q DPat
forall a. a -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> WriterT [(Name, DExp)] q DPat)
-> DPat -> WriterT [(Name, DExp)] q DPat
forall a b. (a -> b) -> a -> b
$ Name -> [DKind] -> [DPat] -> DPat
DConP '(:) [] [DPat
h', DPat
t']
dsPat (SigP Pat
pat Type
ty) = DPat -> DKind -> DPat
DSigP (DPat -> DKind -> DPat)
-> WriterT [(Name, DExp)] q DPat
-> WriterT [(Name, DExp)] q (DKind -> DPat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat WriterT [(Name, DExp)] q (DKind -> DPat)
-> WriterT [(Name, DExp)] q DKind -> WriterT [(Name, DExp)] q DPat
forall a b.
WriterT [(Name, DExp)] q (a -> b)
-> WriterT [(Name, DExp)] q a -> WriterT [(Name, DExp)] q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> WriterT [(Name, DExp)] q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
#if __GLASGOW_HASKELL__ >= 801
dsPat (UnboxedSumP Pat
pat Int
alt Int
arity) =
Name -> [DKind] -> [DPat] -> DPat
DConP (Int -> Int -> Name
unboxedSumDataName Int
alt Int
arity) [] ([DPat] -> DPat)
-> WriterT [(Name, DExp)] q [DPat] -> WriterT [(Name, DExp)] q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((DPat -> [DPat] -> [DPat]
forall a. a -> [a] -> [a]
:[]) (DPat -> [DPat])
-> WriterT [(Name, DExp)] q DPat -> WriterT [(Name, DExp)] q [DPat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat)
#endif
dsPat (ViewP Exp
_ Pat
_) =
String -> WriterT [(Name, DExp)] q DPat
forall a. String -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"View patterns are not supported in th-desugar. Use pattern guards instead."
dPatToDExp :: DPat -> DExp
dPatToDExp :: DPat -> DExp
dPatToDExp (DLitP Lit
lit) = Lit -> DExp
DLitE Lit
lit
dPatToDExp (DVarP Name
name) = Name -> DExp
DVarE Name
name
dPatToDExp (DConP Name
name [DKind]
tys [DPat]
pats) = (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE ((DExp -> DKind -> DExp) -> DExp -> [DKind] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DKind -> DExp
DAppTypeE (Name -> DExp
DConE Name
name) [DKind]
tys) ((DPat -> DExp) -> [DPat] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map DPat -> DExp
dPatToDExp [DPat]
pats)
dPatToDExp (DTildeP DPat
pat) = DPat -> DExp
dPatToDExp DPat
pat
dPatToDExp (DBangP DPat
pat) = DPat -> DExp
dPatToDExp DPat
pat
dPatToDExp (DSigP DPat
pat DKind
ty) = DExp -> DKind -> DExp
DSigE (DPat -> DExp
dPatToDExp DPat
pat) DKind
ty
dPatToDExp DPat
DWildP = String -> DExp
forall a. HasCallStack => String -> a
error String
"Internal error in th-desugar: wildcard in rhs of as-pattern"
removeWilds :: DsMonad q => DPat -> q DPat
removeWilds :: forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds p :: DPat
p@(DLitP Lit
_) = DPat -> q DPat
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
p
removeWilds p :: DPat
p@(DVarP Name
_) = DPat -> q DPat
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
p
removeWilds (DConP Name
con_name [DKind]
tys [DPat]
pats) = Name -> [DKind] -> [DPat] -> DPat
DConP Name
con_name [DKind]
tys ([DPat] -> DPat) -> q [DPat] -> q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DPat -> q DPat) -> [DPat] -> q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds [DPat]
pats
removeWilds (DTildeP DPat
pat) = DPat -> DPat
DTildeP (DPat -> DPat) -> q DPat -> q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat
removeWilds (DBangP DPat
pat) = DPat -> DPat
DBangP (DPat -> DPat) -> q DPat -> q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat
removeWilds (DSigP DPat
pat DKind
ty) = DPat -> DKind -> DPat
DSigP (DPat -> DKind -> DPat) -> q DPat -> q (DKind -> DPat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat q (DKind -> DPat) -> q DKind -> q DPat
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DKind -> q DKind
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DKind
ty
removeWilds DPat
DWildP = Name -> DPat
DVarP (Name -> DPat) -> q Name -> q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"wild"
dsInfo :: DsMonad q => Info -> q DInfo
dsInfo :: forall (q :: * -> *). DsMonad q => Info -> q DInfo
dsInfo (ClassI Dec
dec [Dec]
instances) = do
[DDec
ddec] <- Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec Dec
dec
[DDec]
dinstances <- [Dec] -> q [DDec]
forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
instances
DInfo -> q DInfo
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DInfo -> q DInfo) -> DInfo -> q DInfo
forall a b. (a -> b) -> a -> b
$ DDec -> Maybe [DDec] -> DInfo
DTyConI DDec
ddec ([DDec] -> Maybe [DDec]
forall a. a -> Maybe a
Just [DDec]
dinstances)
dsInfo (ClassOpI Name
name Type
ty Name
parent) =
Name -> DKind -> Maybe Name -> DInfo
DVarI Name
name (DKind -> Maybe Name -> DInfo)
-> q DKind -> q (Maybe Name -> DInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty q (Maybe Name -> DInfo) -> q (Maybe Name) -> q DInfo
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Name -> q (Maybe Name)
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
parent)
dsInfo (TyConI Dec
dec) = do
[DDec
ddec] <- Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec Dec
dec
DInfo -> q DInfo
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DInfo -> q DInfo) -> DInfo -> q DInfo
forall a b. (a -> b) -> a -> b
$ DDec -> Maybe [DDec] -> DInfo
DTyConI DDec
ddec Maybe [DDec]
forall a. Maybe a
Nothing
dsInfo (FamilyI Dec
dec [Dec]
instances) = do
[DDec
ddec] <- Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec Dec
dec
[DDec]
dinstances <- [Dec] -> q [DDec]
forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
instances
DInfo -> q DInfo
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DInfo -> q DInfo) -> DInfo -> q DInfo
forall a b. (a -> b) -> a -> b
$ DDec -> Maybe [DDec] -> DInfo
DTyConI DDec
ddec ([DDec] -> Maybe [DDec]
forall a. a -> Maybe a
Just [DDec]
dinstances)
dsInfo (PrimTyConI Name
name Int
arity Bool
unlifted) =
DInfo -> q DInfo
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DInfo -> q DInfo) -> DInfo -> q DInfo
forall a b. (a -> b) -> a -> b
$ Name -> Int -> Bool -> DInfo
DPrimTyConI Name
name Int
arity Bool
unlifted
dsInfo (DataConI Name
name Type
ty Name
parent) =
Name -> DKind -> Maybe Name -> DInfo
DVarI Name
name (DKind -> Maybe Name -> DInfo)
-> q DKind -> q (Maybe Name -> DInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty q (Maybe Name -> DInfo) -> q (Maybe Name) -> q DInfo
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Name -> q (Maybe Name)
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
parent)
dsInfo (VarI Name
name Type
ty Maybe Dec
Nothing) =
Name -> DKind -> Maybe Name -> DInfo
DVarI Name
name (DKind -> Maybe Name -> DInfo)
-> q DKind -> q (Maybe Name -> DInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty q (Maybe Name -> DInfo) -> q (Maybe Name) -> q DInfo
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Name -> q (Maybe Name)
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Name
forall a. Maybe a
Nothing
dsInfo (VarI Name
name Type
_ (Just Dec
_)) =
String -> q DInfo
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q DInfo) -> String -> q DInfo
forall a b. (a -> b) -> a -> b
$ String
"Declaration supplied with variable: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
name
dsInfo (TyVarI Name
name Type
ty) = Name -> DKind -> DInfo
DTyVarI Name
name (DKind -> DInfo) -> q DKind -> q DInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
#if __GLASGOW_HASKELL__ >= 801
dsInfo (PatSynI Name
name Type
ty) = Name -> DKind -> DInfo
DPatSynI Name
name (DKind -> DInfo) -> q DKind -> q DInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
#endif
dsDecs :: DsMonad q => [Dec] -> q [DDec]
dsDecs :: forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs = (Dec -> q [DDec]) -> [Dec] -> q [DDec]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec
dsDec :: DsMonad q => Dec -> q [DDec]
dsDec :: forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec d :: Dec
d@(FunD {}) = Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec d :: Dec
d@(ValD {}) = Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec (DataD [Type]
cxt Name
n [TyVarBndrUnit]
tvbs Maybe Type
mk [Con]
cons [DerivClause]
derivings) =
DataFlavor
-> [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataDec DataFlavor
Data [Type]
cxt Name
n [TyVarBndrUnit]
tvbs Maybe Type
mk [Con]
cons [DerivClause]
derivings
dsDec (NewtypeD [Type]
cxt Name
n [TyVarBndrUnit]
tvbs Maybe Type
mk Con
con [DerivClause]
derivings) =
DataFlavor
-> [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataDec DataFlavor
Newtype [Type]
cxt Name
n [TyVarBndrUnit]
tvbs Maybe Type
mk [Con
con] [DerivClause]
derivings
dsDec (TySynD Name
n [TyVarBndrUnit]
tvbs Type
ty) =
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> [DTyVarBndrUnit] -> DKind -> DDec
DTySynD Name
n ([DTyVarBndrUnit] -> DKind -> DDec)
-> q [DTyVarBndrUnit] -> q (DKind -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndrUnit -> q DTyVarBndrUnit)
-> [TyVarBndrUnit] -> q [DTyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrUnit -> q DTyVarBndrUnit
forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit [TyVarBndrUnit]
tvbs q (DKind -> DDec) -> q DKind -> q DDec
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty)
dsDec (ClassD [Type]
cxt Name
n [TyVarBndrUnit]
tvbs [FunDep]
fds [Dec]
decs) =
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DKind] -> Name -> [DTyVarBndrUnit] -> [FunDep] -> [DDec] -> DDec
DClassD ([DKind] -> Name -> [DTyVarBndrUnit] -> [FunDep] -> [DDec] -> DDec)
-> q [DKind]
-> q (Name -> [DTyVarBndrUnit] -> [FunDep] -> [DDec] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt q (Name -> [DTyVarBndrUnit] -> [FunDep] -> [DDec] -> DDec)
-> q Name -> q ([DTyVarBndrUnit] -> [FunDep] -> [DDec] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> q Name
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n q ([DTyVarBndrUnit] -> [FunDep] -> [DDec] -> DDec)
-> q [DTyVarBndrUnit] -> q ([FunDep] -> [DDec] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TyVarBndrUnit -> q DTyVarBndrUnit)
-> [TyVarBndrUnit] -> q [DTyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrUnit -> q DTyVarBndrUnit
forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit [TyVarBndrUnit]
tvbs
q ([FunDep] -> [DDec] -> DDec) -> q [FunDep] -> q ([DDec] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [FunDep] -> q [FunDep]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FunDep]
fds q ([DDec] -> DDec) -> q [DDec] -> q DDec
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Dec] -> q [DDec]
forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
decs)
dsDec (InstanceD Maybe Overlap
over [Type]
cxt Type
ty [Dec]
decs) =
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe Overlap
-> Maybe [DTyVarBndrUnit] -> [DKind] -> DKind -> [DDec] -> DDec
DInstanceD Maybe Overlap
over Maybe [DTyVarBndrUnit]
forall a. Maybe a
Nothing ([DKind] -> DKind -> [DDec] -> DDec)
-> q [DKind] -> q (DKind -> [DDec] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt q (DKind -> [DDec] -> DDec) -> q DKind -> q ([DDec] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty q ([DDec] -> DDec) -> q [DDec] -> q DDec
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Dec] -> q [DDec]
forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
decs)
dsDec d :: Dec
d@(SigD {}) = Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec (ForeignD Foreign
f) = (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DForeign -> DDec
DForeignD (DForeign -> DDec) -> q DForeign -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Foreign -> q DForeign
forall (q :: * -> *). DsMonad q => Foreign -> q DForeign
dsForeign Foreign
f)
dsDec d :: Dec
d@(InfixD {}) = Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec d :: Dec
d@(PragmaD {}) = Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec (OpenTypeFamilyD TypeFamilyHead
tfHead) =
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DTypeFamilyHead -> DDec
DOpenTypeFamilyD (DTypeFamilyHead -> DDec) -> q DTypeFamilyHead -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeFamilyHead -> q DTypeFamilyHead
forall (q :: * -> *).
DsMonad q =>
TypeFamilyHead -> q DTypeFamilyHead
dsTypeFamilyHead TypeFamilyHead
tfHead)
dsDec (DataFamilyD Name
n [TyVarBndrUnit]
tvbs Maybe Type
m_k) =
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> [DTyVarBndrUnit] -> Maybe DKind -> DDec
DDataFamilyD Name
n ([DTyVarBndrUnit] -> Maybe DKind -> DDec)
-> q [DTyVarBndrUnit] -> q (Maybe DKind -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndrUnit -> q DTyVarBndrUnit)
-> [TyVarBndrUnit] -> q [DTyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrUnit -> q DTyVarBndrUnit
forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit [TyVarBndrUnit]
tvbs q (Maybe DKind -> DDec) -> q (Maybe DKind) -> q DDec
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> q DKind) -> Maybe Type -> q (Maybe DKind)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Maybe Type
m_k)
#if __GLASGOW_HASKELL__ >= 807
dsDec (DataInstD [Type]
cxt Maybe [TyVarBndrUnit]
mtvbs Type
lhs Maybe Type
mk [Con]
cons [DerivClause]
derivings) =
case Type -> (Type, [TypeArg])
unfoldType Type
lhs of
(ConT Name
n, [TypeArg]
tys) -> DataFlavor
-> [Type]
-> Name
-> Maybe [TyVarBndrUnit]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> Maybe [TyVarBndrUnit]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataInstDec DataFlavor
Data [Type]
cxt Name
n Maybe [TyVarBndrUnit]
mtvbs [TypeArg]
tys Maybe Type
mk [Con]
cons [DerivClause]
derivings
(Type
_, [TypeArg]
_) -> String -> q [DDec]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q [DDec]) -> String -> q [DDec]
forall a b. (a -> b) -> a -> b
$ String
"Unexpected data instance LHS: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
lhs
dsDec (NewtypeInstD [Type]
cxt Maybe [TyVarBndrUnit]
mtvbs Type
lhs Maybe Type
mk Con
con [DerivClause]
derivings) =
case Type -> (Type, [TypeArg])
unfoldType Type
lhs of
(ConT Name
n, [TypeArg]
tys) -> DataFlavor
-> [Type]
-> Name
-> Maybe [TyVarBndrUnit]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> Maybe [TyVarBndrUnit]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataInstDec DataFlavor
Newtype [Type]
cxt Name
n Maybe [TyVarBndrUnit]
mtvbs [TypeArg]
tys Maybe Type
mk [Con
con] [DerivClause]
derivings
(Type
_, [TypeArg]
_) -> String -> q [DDec]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q [DDec]) -> String -> q [DDec]
forall a b. (a -> b) -> a -> b
$ String
"Unexpected newtype instance LHS: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
lhs
#else
dsDec (DataInstD cxt n tys mk cons derivings) =
dsDataInstDec Data cxt n Nothing (map TANormal tys) mk cons derivings
dsDec (NewtypeInstD cxt n tys mk con derivings) =
dsDataInstDec Newtype cxt n Nothing (map TANormal tys) mk [con] derivings
#endif
#if __GLASGOW_HASKELL__ >= 807
dsDec (TySynInstD TySynEqn
eqn) = (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DTySynEqn -> DDec
DTySynInstD (DTySynEqn -> DDec) -> q DTySynEqn -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TySynEqn -> q DTySynEqn
forall (q :: * -> *). DsMonad q => Name -> TySynEqn -> q DTySynEqn
dsTySynEqn Name
forall a. a
unusedArgument TySynEqn
eqn)
#else
dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn)
#endif
dsDec (ClosedTypeFamilyD TypeFamilyHead
tfHead [TySynEqn]
eqns) =
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DTypeFamilyHead -> [DTySynEqn] -> DDec
DClosedTypeFamilyD (DTypeFamilyHead -> [DTySynEqn] -> DDec)
-> q DTypeFamilyHead -> q ([DTySynEqn] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeFamilyHead -> q DTypeFamilyHead
forall (q :: * -> *).
DsMonad q =>
TypeFamilyHead -> q DTypeFamilyHead
dsTypeFamilyHead TypeFamilyHead
tfHead
q ([DTySynEqn] -> DDec) -> q [DTySynEqn] -> q DDec
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TySynEqn -> q DTySynEqn) -> [TySynEqn] -> q [DTySynEqn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name -> TySynEqn -> q DTySynEqn
forall (q :: * -> *). DsMonad q => Name -> TySynEqn -> q DTySynEqn
dsTySynEqn (TypeFamilyHead -> Name
typeFamilyHeadName TypeFamilyHead
tfHead)) [TySynEqn]
eqns)
dsDec (RoleAnnotD Name
n [Role]
roles) = [DDec] -> q [DDec]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> [Role] -> DDec
DRoleAnnotD Name
n [Role]
roles]
#if __GLASGOW_HASKELL__ >= 801
dsDec (PatSynD Name
n PatSynArgs
args PatSynDir
dir Pat
pat) = do
DPatSynDir
dir' <- Name -> PatSynDir -> q DPatSynDir
forall (q :: * -> *).
DsMonad q =>
Name -> PatSynDir -> q DPatSynDir
dsPatSynDir Name
n PatSynDir
dir
(DPat
pat', [(Name, DExp)]
vars) <- Pat -> q (DPat, [(Name, DExp)])
forall (q :: * -> *). DsMonad q => Pat -> q (DPat, [(Name, DExp)])
dsPatX Pat
pat
Bool -> q () -> q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Name, DExp)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, DExp)]
vars) (q () -> q ()) -> q () -> q ()
forall a b. (a -> b) -> a -> b
$
String -> q ()
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q ()) -> String -> q ()
forall a b. (a -> b) -> a -> b
$ String
"Pattern synonym definition cannot contain as-patterns (@)."
[DDec] -> q [DDec]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> PatSynArgs -> DPatSynDir -> DPat -> DDec
DPatSynD Name
n PatSynArgs
args DPatSynDir
dir' DPat
pat']
dsDec (PatSynSigD Name
n Type
ty) = (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> DKind -> DDec
DPatSynSigD Name
n (DKind -> DDec) -> q DKind -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty)
dsDec (StandaloneDerivD Maybe DerivStrategy
mds [Type]
cxt Type
ty) =
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe DDerivStrategy
-> Maybe [DTyVarBndrUnit] -> [DKind] -> DKind -> DDec
DStandaloneDerivD (Maybe DDerivStrategy
-> Maybe [DTyVarBndrUnit] -> [DKind] -> DKind -> DDec)
-> q (Maybe DDerivStrategy)
-> q (Maybe [DTyVarBndrUnit] -> [DKind] -> DKind -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DerivStrategy -> q DDerivStrategy)
-> Maybe DerivStrategy -> q (Maybe DDerivStrategy)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM DerivStrategy -> q DDerivStrategy
forall (q :: * -> *).
DsMonad q =>
DerivStrategy -> q DDerivStrategy
dsDerivStrategy Maybe DerivStrategy
mds
q (Maybe [DTyVarBndrUnit] -> [DKind] -> DKind -> DDec)
-> q (Maybe [DTyVarBndrUnit]) -> q ([DKind] -> DKind -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [DTyVarBndrUnit] -> q (Maybe [DTyVarBndrUnit])
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [DTyVarBndrUnit]
forall a. Maybe a
Nothing q ([DKind] -> DKind -> DDec) -> q [DKind] -> q (DKind -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt q (DKind -> DDec) -> q DKind -> q DDec
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty)
#else
dsDec (StandaloneDerivD cxt ty) =
(:[]) <$> (DStandaloneDerivD Nothing Nothing <$> dsCxt cxt <*> dsType ty)
#endif
dsDec (DefaultSigD Name
n Type
ty) = (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> DKind -> DDec
DDefaultSigD Name
n (DKind -> DDec) -> q DKind -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty)
#if __GLASGOW_HASKELL__ >= 807
dsDec (ImplicitParamBindD {}) = String -> q [DDec]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Non-`let`-bound implicit param binding"
#endif
#if __GLASGOW_HASKELL__ >= 809
dsDec (KiSigD Name
n Type
ki) = (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> DKind -> DDec
DKiSigD Name
n (DKind -> DDec) -> q DKind -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ki)
#endif
#if __GLASGOW_HASKELL__ >= 903
dsDec (DefaultD [Type]
tys) = (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DKind] -> DDec
DDefaultD ([DKind] -> DDec) -> q [DKind] -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> q DKind) -> [Type] -> q [DKind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType [Type]
tys)
#endif
#if __GLASGOW_HASKELL__ >= 906
dsDec (TypeDataD Name
n [TyVarBndrUnit]
tys Maybe Type
mk [Con]
cons) =
DataFlavor
-> [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataDec DataFlavor
TypeData [] Name
n [TyVarBndrUnit]
tys Maybe Type
mk [Con]
cons []
#endif
dsDataDec :: DsMonad q
=> DataFlavor -> Cxt -> Name -> [TyVarBndrUnit]
-> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]
dsDataDec :: forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataDec DataFlavor
nd [Type]
cxt Name
n [TyVarBndrUnit]
tvbs Maybe Type
mk [Con]
cons [DerivClause]
derivings = do
[DTyVarBndrUnit]
tvbs' <- (TyVarBndrUnit -> q DTyVarBndrUnit)
-> [TyVarBndrUnit] -> q [DTyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrUnit -> q DTyVarBndrUnit
forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit [TyVarBndrUnit]
tvbs
let h98_tvbs :: [DTyVarBndrUnit]
h98_tvbs = case Maybe Type
mk of
Just {} -> [DTyVarBndrUnit]
forall a. a
unusedArgument
Maybe Type
Nothing -> [DTyVarBndrUnit]
tvbs'
h98_return_type :: DKind
h98_return_type = Name -> [DTyVarBndrUnit] -> DKind
nonFamilyDataReturnType Name
n [DTyVarBndrUnit]
tvbs'
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataFlavor
-> [DKind]
-> Name
-> [DTyVarBndrUnit]
-> Maybe DKind
-> [DCon]
-> [DDerivClause]
-> DDec
DDataD DataFlavor
nd ([DKind]
-> Name
-> [DTyVarBndrUnit]
-> Maybe DKind
-> [DCon]
-> [DDerivClause]
-> DDec)
-> q [DKind]
-> q (Name
-> [DTyVarBndrUnit]
-> Maybe DKind
-> [DCon]
-> [DDerivClause]
-> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt q (Name
-> [DTyVarBndrUnit]
-> Maybe DKind
-> [DCon]
-> [DDerivClause]
-> DDec)
-> q Name
-> q ([DTyVarBndrUnit]
-> Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> q Name
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
q ([DTyVarBndrUnit]
-> Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
-> q [DTyVarBndrUnit]
-> q (Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [DTyVarBndrUnit] -> q [DTyVarBndrUnit]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [DTyVarBndrUnit]
tvbs' q (Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
-> q (Maybe DKind) -> q ([DCon] -> [DDerivClause] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> q DKind) -> Maybe Type -> q (Maybe DKind)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Maybe Type
mk
q ([DCon] -> [DDerivClause] -> DDec)
-> q [DCon] -> q ([DDerivClause] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Con -> q [DCon]) -> [Con] -> q [DCon]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM ([DTyVarBndrUnit] -> DKind -> Con -> q [DCon]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndrUnit] -> DKind -> Con -> q [DCon]
dsCon [DTyVarBndrUnit]
h98_tvbs DKind
h98_return_type) [Con]
cons
q ([DDerivClause] -> DDec) -> q [DDerivClause] -> q DDec
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (DerivClause -> q DDerivClause)
-> [DerivClause] -> q [DDerivClause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DerivClause -> q DDerivClause
forall (q :: * -> *). DsMonad q => DerivClause -> q DDerivClause
dsDerivClause [DerivClause]
derivings)
dsDataInstDec :: DsMonad q
=> DataFlavor -> Cxt -> Name -> Maybe [TyVarBndrUnit] -> [TypeArg]
-> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]
dsDataInstDec :: forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> Maybe [TyVarBndrUnit]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataInstDec DataFlavor
nd [Type]
cxt Name
n Maybe [TyVarBndrUnit]
mtvbs [TypeArg]
tys Maybe Type
mk [Con]
cons [DerivClause]
derivings = do
Maybe [DTyVarBndrUnit]
mtvbs' <- ([TyVarBndrUnit] -> q [DTyVarBndrUnit])
-> Maybe [TyVarBndrUnit] -> q (Maybe [DTyVarBndrUnit])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM ((TyVarBndrUnit -> q DTyVarBndrUnit)
-> [TyVarBndrUnit] -> q [DTyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrUnit -> q DTyVarBndrUnit
forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit) Maybe [TyVarBndrUnit]
mtvbs
[DTypeArg]
tys' <- (TypeArg -> q DTypeArg) -> [TypeArg] -> q [DTypeArg]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TypeArg -> q DTypeArg
forall (q :: * -> *). DsMonad q => TypeArg -> q DTypeArg
dsTypeArg [TypeArg]
tys
let lhs' :: DKind
lhs' = DKind -> [DTypeArg] -> DKind
applyDType (Name -> DKind
DConT Name
n) [DTypeArg]
tys'
h98_tvbs :: [DTyVarBndrUnit]
h98_tvbs =
case (Maybe Type
mk, Maybe [DTyVarBndrUnit]
mtvbs') of
(Just {}, Maybe [DTyVarBndrUnit]
_) -> [DTyVarBndrUnit]
forall a. a
unusedArgument
(Maybe Type
Nothing, Just [DTyVarBndrUnit]
tvbs') -> [DTyVarBndrUnit]
tvbs'
(Maybe Type
Nothing, Maybe [DTyVarBndrUnit]
Nothing) -> [DTypeArg] -> [DTyVarBndrUnit]
dataFamInstTvbs [DTypeArg]
tys'
h98_fam_inst_type :: DKind
h98_fam_inst_type = Name -> [DTypeArg] -> DKind
dataFamInstReturnType Name
n [DTypeArg]
tys'
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataFlavor
-> [DKind]
-> Maybe [DTyVarBndrUnit]
-> DKind
-> Maybe DKind
-> [DCon]
-> [DDerivClause]
-> DDec
DDataInstD DataFlavor
nd ([DKind]
-> Maybe [DTyVarBndrUnit]
-> DKind
-> Maybe DKind
-> [DCon]
-> [DDerivClause]
-> DDec)
-> q [DKind]
-> q (Maybe [DTyVarBndrUnit]
-> DKind -> Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt q (Maybe [DTyVarBndrUnit]
-> DKind -> Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
-> q (Maybe [DTyVarBndrUnit])
-> q (DKind -> Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [DTyVarBndrUnit] -> q (Maybe [DTyVarBndrUnit])
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [DTyVarBndrUnit]
mtvbs'
q (DKind -> Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
-> q DKind -> q (Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DKind -> q DKind
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DKind
lhs' q (Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
-> q (Maybe DKind) -> q ([DCon] -> [DDerivClause] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> q DKind) -> Maybe Type -> q (Maybe DKind)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Maybe Type
mk
q ([DCon] -> [DDerivClause] -> DDec)
-> q [DCon] -> q ([DDerivClause] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Con -> q [DCon]) -> [Con] -> q [DCon]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM ([DTyVarBndrUnit] -> DKind -> Con -> q [DCon]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndrUnit] -> DKind -> Con -> q [DCon]
dsCon [DTyVarBndrUnit]
h98_tvbs DKind
h98_fam_inst_type) [Con]
cons
q ([DDerivClause] -> DDec) -> q [DDerivClause] -> q DDec
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (DerivClause -> q DDerivClause)
-> [DerivClause] -> q [DDerivClause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DerivClause -> q DDerivClause
forall (q :: * -> *). DsMonad q => DerivClause -> q DDerivClause
dsDerivClause [DerivClause]
derivings)
dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig
dsFamilyResultSig :: forall (q :: * -> *).
DsMonad q =>
FamilyResultSig -> q DFamilyResultSig
dsFamilyResultSig FamilyResultSig
NoSig = DFamilyResultSig -> q DFamilyResultSig
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DFamilyResultSig
DNoSig
dsFamilyResultSig (KindSig Type
k) = DKind -> DFamilyResultSig
DKindSig (DKind -> DFamilyResultSig) -> q DKind -> q DFamilyResultSig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
k
dsFamilyResultSig (TyVarSig TyVarBndrUnit
tvb) = DTyVarBndrUnit -> DFamilyResultSig
DTyVarSig (DTyVarBndrUnit -> DFamilyResultSig)
-> q DTyVarBndrUnit -> q DFamilyResultSig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVarBndrUnit -> q DTyVarBndrUnit
forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit TyVarBndrUnit
tvb
dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead
dsTypeFamilyHead :: forall (q :: * -> *).
DsMonad q =>
TypeFamilyHead -> q DTypeFamilyHead
dsTypeFamilyHead (TypeFamilyHead Name
n [TyVarBndrUnit]
tvbs FamilyResultSig
result Maybe InjectivityAnn
inj)
= Name
-> [DTyVarBndrUnit]
-> DFamilyResultSig
-> Maybe InjectivityAnn
-> DTypeFamilyHead
DTypeFamilyHead Name
n ([DTyVarBndrUnit]
-> DFamilyResultSig -> Maybe InjectivityAnn -> DTypeFamilyHead)
-> q [DTyVarBndrUnit]
-> q (DFamilyResultSig -> Maybe InjectivityAnn -> DTypeFamilyHead)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndrUnit -> q DTyVarBndrUnit)
-> [TyVarBndrUnit] -> q [DTyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrUnit -> q DTyVarBndrUnit
forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit [TyVarBndrUnit]
tvbs
q (DFamilyResultSig -> Maybe InjectivityAnn -> DTypeFamilyHead)
-> q DFamilyResultSig
-> q (Maybe InjectivityAnn -> DTypeFamilyHead)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FamilyResultSig -> q DFamilyResultSig
forall (q :: * -> *).
DsMonad q =>
FamilyResultSig -> q DFamilyResultSig
dsFamilyResultSig FamilyResultSig
result
q (Maybe InjectivityAnn -> DTypeFamilyHead)
-> q (Maybe InjectivityAnn) -> q DTypeFamilyHead
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe InjectivityAnn -> q (Maybe InjectivityAnn)
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe InjectivityAnn
inj
typeFamilyHeadName :: TypeFamilyHead -> Name
typeFamilyHeadName :: TypeFamilyHead -> Name
typeFamilyHeadName (TypeFamilyHead Name
n [TyVarBndrUnit]
_ FamilyResultSig
_ Maybe InjectivityAnn
_) = Name
n
dsLetDecs :: DsMonad q => [Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs :: forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs = do
([[DLetDec]]
let_decss, [DExp -> DExp]
ip_binders) <- (Dec -> q ([DLetDec], DExp -> DExp))
-> [Dec] -> q ([[DLetDec]], [DExp -> DExp])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM Dec -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
Dec -> q ([DLetDec], DExp -> DExp)
dsLetDec [Dec]
decs
let let_decs :: [DLetDec]
let_decs :: [DLetDec]
let_decs = [[DLetDec]] -> [DLetDec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[DLetDec]]
let_decss
ip_binder :: DExp -> DExp
ip_binder :: DExp -> DExp
ip_binder = ((DExp -> DExp) -> (DExp -> DExp) -> DExp -> DExp)
-> (DExp -> DExp) -> [DExp -> DExp] -> DExp -> DExp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (DExp -> DExp) -> (DExp -> DExp) -> DExp -> DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) DExp -> DExp
forall a. a -> a
id [DExp -> DExp]
ip_binders
([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DLetDec]
let_decs, DExp -> DExp
ip_binder)
dsLetDec :: DsMonad q => Dec -> q ([DLetDec], DExp -> DExp)
dsLetDec :: forall (q :: * -> *).
DsMonad q =>
Dec -> q ([DLetDec], DExp -> DExp)
dsLetDec (FunD Name
name [Clause]
clauses) = do
[DClause]
clauses' <- MatchContext -> [Clause] -> q [DClause]
forall (q :: * -> *).
DsMonad q =>
MatchContext -> [Clause] -> q [DClause]
dsClauses (Name -> MatchContext
FunRhs Name
name) [Clause]
clauses
([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name -> [DClause] -> DLetDec
DFunD Name
name [DClause]
clauses'], DExp -> DExp
forall a. a -> a
id)
dsLetDec (ValD Pat
pat Body
body [Dec]
where_decs) = do
(DPat
pat', [(Name, DExp)]
vars) <- Pat -> q (DPat, [(Name, DExp)])
forall (q :: * -> *). DsMonad q => Pat -> q (DPat, [(Name, DExp)])
dsPatX Pat
pat
DExp
body' <- Body -> [Dec] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody Body
body [Dec]
where_decs DExp
error_exp
let extras :: [DLetDec]
extras = ([Name] -> [DExp] -> [DLetDec]) -> ([Name], [DExp]) -> [DLetDec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Name -> DExp -> DLetDec) -> [Name] -> [DExp] -> [DLetDec]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (DPat -> DExp -> DLetDec
DValD (DPat -> DExp -> DLetDec)
-> (Name -> DPat) -> Name -> DExp -> DLetDec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DPat
DVarP)) (([Name], [DExp]) -> [DLetDec]) -> ([Name], [DExp]) -> [DLetDec]
forall a b. (a -> b) -> a -> b
$ [(Name, DExp)] -> ([Name], [DExp])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Name, DExp)]
vars
([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> DExp -> DLetDec
DValD DPat
pat' DExp
body' DLetDec -> [DLetDec] -> [DLetDec]
forall a. a -> [a] -> [a]
: [DLetDec]
extras, DExp -> DExp
forall a. a -> a
id)
where
error_exp :: DExp
error_exp = MatchContext -> DExp
mkErrorMatchExpr (Pat -> MatchContext
LetDecRhs Pat
pat)
dsLetDec (SigD Name
name Type
ty) = do
DKind
ty' <- Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name -> DKind -> DLetDec
DSigD Name
name DKind
ty'], DExp -> DExp
forall a. a -> a
id)
dsLetDec (InfixD Fixity
fixity Name
name) = ([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Fixity -> Name -> DLetDec
DInfixD Fixity
fixity Name
name], DExp -> DExp
forall a. a -> a
id)
dsLetDec (PragmaD Pragma
prag) = do
DPragma
prag' <- Pragma -> q DPragma
forall (q :: * -> *). DsMonad q => Pragma -> q DPragma
dsPragma Pragma
prag
([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DPragma -> DLetDec
DPragmaD DPragma
prag'], DExp -> DExp
forall a. a -> a
id)
#if __GLASGOW_HASKELL__ >= 807
dsLetDec (ImplicitParamBindD String
n Exp
e) = do
Name
new_n_name <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
qNewName (String -> q Name) -> String -> q Name
forall a b. (a -> b) -> a -> b
$ String
"new_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_val"
DExp
e' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e
let let_dec :: DLetDec
let_dec :: DLetDec
let_dec = DPat -> DExp -> DLetDec
DValD (Name -> DPat
DVarP Name
new_n_name) DExp
e'
ip_binder :: DExp -> DExp
ip_binder :: DExp -> DExp
ip_binder = (Name -> DExp
DVarE 'bindIP DExp -> DKind -> DExp
`DAppTypeE`
TyLit -> DKind
DLitT (String -> TyLit
StrTyLit String
n) DExp -> DExp -> DExp
`DAppE`
Name -> DExp
DVarE Name
new_n_name DExp -> DExp -> DExp
`DAppE`)
([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DLetDec
let_dec], DExp -> DExp
ip_binder)
#endif
dsLetDec Dec
_dec = String -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Illegal declaration in let expression."
dsTopLevelLetDec :: DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec :: forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec = (([DLetDec], DExp -> DExp) -> [DDec])
-> q ([DLetDec], DExp -> DExp) -> q [DDec]
forall a b. (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DLetDec -> DDec) -> [DLetDec] -> [DDec]
forall a b. (a -> b) -> [a] -> [b]
map DLetDec -> DDec
DLetDec ([DLetDec] -> [DDec])
-> (([DLetDec], DExp -> DExp) -> [DLetDec])
-> ([DLetDec], DExp -> DExp)
-> [DDec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([DLetDec], DExp -> DExp) -> [DLetDec]
forall a b. (a, b) -> a
fst) (q ([DLetDec], DExp -> DExp) -> q [DDec])
-> (Dec -> q ([DLetDec], DExp -> DExp)) -> Dec -> q [DDec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
Dec -> q ([DLetDec], DExp -> DExp)
dsLetDec
dsCon :: DsMonad q
=> [DTyVarBndrUnit]
-> DType
-> Con -> q [DCon]
dsCon :: forall (q :: * -> *).
DsMonad q =>
[DTyVarBndrUnit] -> DKind -> Con -> q [DCon]
dsCon [DTyVarBndrUnit]
univ_dtvbs DKind
data_type Con
con = do
[(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
dcons' <- Con
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall (q :: * -> *).
DsMonad q =>
Con
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
dsCon' Con
con
[DCon] -> q [DCon]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DCon] -> q [DCon]) -> [DCon] -> q [DCon]
forall a b. (a -> b) -> a -> b
$ (((Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)
-> DCon)
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> [DCon])
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> ((Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)
-> DCon)
-> [DCon]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)
-> DCon)
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> [DCon]
forall a b. (a -> b) -> [a] -> [b]
map [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
dcons' (((Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)
-> DCon)
-> [DCon])
-> ((Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)
-> DCon)
-> [DCon]
forall a b. (a -> b) -> a -> b
$ \(Name
n, [DTyVarBndrSpec]
dtvbs, [DKind]
dcxt, DConFields
fields, Maybe DKind
m_gadt_type) ->
case Maybe DKind
m_gadt_type of
Maybe DKind
Nothing ->
let ex_dtvbs :: [DTyVarBndrSpec]
ex_dtvbs = [DTyVarBndrSpec]
dtvbs
expl_dtvbs :: [DTyVarBndrSpec]
expl_dtvbs = Specificity -> [DTyVarBndrUnit] -> [DTyVarBndrSpec]
forall newFlag oldFlag.
newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags Specificity
SpecifiedSpec [DTyVarBndrUnit]
univ_dtvbs [DTyVarBndrSpec] -> [DTyVarBndrSpec] -> [DTyVarBndrSpec]
forall a. [a] -> [a] -> [a]
++
[DTyVarBndrSpec]
ex_dtvbs
impl_dtvbs :: [DTyVarBndrSpec]
impl_dtvbs = Specificity -> [DTyVarBndrUnit] -> [DTyVarBndrSpec]
forall newFlag oldFlag.
newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags Specificity
SpecifiedSpec ([DTyVarBndrUnit] -> [DTyVarBndrSpec])
-> [DTyVarBndrUnit] -> [DTyVarBndrSpec]
forall a b. (a -> b) -> a -> b
$
[DKind] -> [DTyVarBndrUnit]
toposortTyVarsOf ([DKind] -> [DTyVarBndrUnit]) -> [DKind] -> [DTyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$ (DTyVarBndrSpec -> Maybe DKind) -> [DTyVarBndrSpec] -> [DKind]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DTyVarBndrSpec -> Maybe DKind
forall flag. DTyVarBndr flag -> Maybe DKind
extractTvbKind [DTyVarBndrSpec]
expl_dtvbs in
[DTyVarBndrSpec] -> [DKind] -> Name -> DConFields -> DKind -> DCon
DCon ([DTyVarBndrSpec]
impl_dtvbs [DTyVarBndrSpec] -> [DTyVarBndrSpec] -> [DTyVarBndrSpec]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndrSpec]
expl_dtvbs) [DKind]
dcxt Name
n DConFields
fields DKind
data_type
Just DKind
gadt_type ->
let univ_ex_dtvbs :: [DTyVarBndrSpec]
univ_ex_dtvbs = [DTyVarBndrSpec]
dtvbs in
[DTyVarBndrSpec] -> [DKind] -> Name -> DConFields -> DKind -> DCon
DCon [DTyVarBndrSpec]
univ_ex_dtvbs [DKind]
dcxt Name
n DConFields
fields DKind
gadt_type
dsCon' :: DsMonad q
=> Con -> q [(Name, [DTyVarBndrSpec], DCxt, DConFields, Maybe DType)]
dsCon' :: forall (q :: * -> *).
DsMonad q =>
Con
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
dsCon' (NormalC Name
n [BangType]
stys) = do
[DBangType]
dtys <- (BangType -> q DBangType) -> [BangType] -> q [DBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType [BangType]
stys
[(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
n, [], [], Bool -> [DBangType] -> DConFields
DNormalC Bool
False [DBangType]
dtys, Maybe DKind
forall a. Maybe a
Nothing)]
dsCon' (RecC Name
n [VarBangType]
vstys) = do
[DVarBangType]
vdtys <- (VarBangType -> q DVarBangType)
-> [VarBangType] -> q [DVarBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM VarBangType -> q DVarBangType
forall (q :: * -> *). DsMonad q => VarBangType -> q DVarBangType
dsVarBangType [VarBangType]
vstys
[(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
n, [], [], [DVarBangType] -> DConFields
DRecC [DVarBangType]
vdtys, Maybe DKind
forall a. Maybe a
Nothing)]
dsCon' (InfixC BangType
sty1 Name
n BangType
sty2) = do
DBangType
dty1 <- BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType BangType
sty1
DBangType
dty2 <- BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType BangType
sty2
[(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
n, [], [], Bool -> [DBangType] -> DConFields
DNormalC Bool
True [DBangType
dty1, DBangType
dty2], Maybe DKind
forall a. Maybe a
Nothing)]
dsCon' (ForallC [TyVarBndr Specificity]
tvbs [Type]
cxt Con
con) = do
[DTyVarBndrSpec]
dtvbs <- (TyVarBndr Specificity -> q DTyVarBndrSpec)
-> [TyVarBndr Specificity] -> q [DTyVarBndrSpec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndr Specificity -> q DTyVarBndrSpec
forall (q :: * -> *).
DsMonad q =>
TyVarBndr Specificity -> q DTyVarBndrSpec
dsTvbSpec [TyVarBndr Specificity]
tvbs
[DKind]
dcxt <- [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt
[(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
dcons' <- Con
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall (q :: * -> *).
DsMonad q =>
Con
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
dsCon' Con
con
[(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)])
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a b. (a -> b) -> a -> b
$ (((Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)
-> (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind))
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)])
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> ((Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)
-> (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind))
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)
-> (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind))
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a b. (a -> b) -> [a] -> [b]
map [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
dcons' (((Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)
-> (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind))
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)])
-> ((Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)
-> (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind))
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a b. (a -> b) -> a -> b
$ \(Name
n, [DTyVarBndrSpec]
dtvbs', [DKind]
dcxt', DConFields
fields, Maybe DKind
m_gadt_type) ->
(Name
n, [DTyVarBndrSpec]
dtvbs [DTyVarBndrSpec] -> [DTyVarBndrSpec] -> [DTyVarBndrSpec]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndrSpec]
dtvbs', [DKind]
dcxt [DKind] -> [DKind] -> [DKind]
forall a. [a] -> [a] -> [a]
++ [DKind]
dcxt', DConFields
fields, Maybe DKind
m_gadt_type)
dsCon' (GadtC [Name]
nms [BangType]
btys Type
rty) = do
[DBangType]
dbtys <- (BangType -> q DBangType) -> [BangType] -> q [DBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType [BangType]
btys
DKind
drty <- Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
rty
[q (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([q (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)])
-> [q (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a b. (a -> b) -> a -> b
$ ((Name
-> q (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind))
-> [Name]
-> [q (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)])
-> [Name]
-> (Name
-> q (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind))
-> [q (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name
-> q (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind))
-> [Name]
-> [q (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a b. (a -> b) -> [a] -> [b]
map [Name]
nms ((Name
-> q (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind))
-> [q (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)])
-> (Name
-> q (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind))
-> [q (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a b. (a -> b) -> a -> b
$ \Name
nm -> do
Maybe Fixity
mbFi <- Name -> q (Maybe Fixity)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Fixity)
reifyFixityWithLocals Name
nm
let decInfix :: Bool
decInfix = String -> Bool
isInfixDataCon (Name -> String
nameBase Name
nm)
Bool -> Bool -> Bool
&& [DBangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DBangType]
dbtys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
Bool -> Bool -> Bool
&& Maybe Fixity -> Bool
forall a. Maybe a -> Bool
isJust Maybe Fixity
mbFi
(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)
-> q (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, [], [], Bool -> [DBangType] -> DConFields
DNormalC Bool
decInfix [DBangType]
dbtys, DKind -> Maybe DKind
forall a. a -> Maybe a
Just DKind
drty)
dsCon' (RecGadtC [Name]
nms [VarBangType]
vbtys Type
rty) = do
[DVarBangType]
dvbtys <- (VarBangType -> q DVarBangType)
-> [VarBangType] -> q [DVarBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM VarBangType -> q DVarBangType
forall (q :: * -> *). DsMonad q => VarBangType -> q DVarBangType
dsVarBangType [VarBangType]
vbtys
DKind
drty <- Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
rty
[(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)])
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a b. (a -> b) -> a -> b
$ ((Name
-> (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind))
-> [Name]
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)])
-> [Name]
-> (Name
-> (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind))
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name
-> (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind))
-> [Name]
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a b. (a -> b) -> [a] -> [b]
map [Name]
nms ((Name
-> (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind))
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)])
-> (Name
-> (Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind))
-> [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
forall a b. (a -> b) -> a -> b
$ \Name
nm ->
(Name
nm, [], [], [DVarBangType] -> DConFields
DRecC [DVarBangType]
dvbtys, DKind -> Maybe DKind
forall a. a -> Maybe a
Just DKind
drty)
dsBangType :: DsMonad q => BangType -> q DBangType
dsBangType :: forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType (Bang
b, Type
ty) = (Bang
b, ) (DKind -> DBangType) -> q DKind -> q DBangType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType
dsVarBangType :: forall (q :: * -> *). DsMonad q => VarBangType -> q DVarBangType
dsVarBangType (Name
n, Bang
b, Type
ty) = (Name
n, Bang
b, ) (DKind -> DVarBangType) -> q DKind -> q DVarBangType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
dsForeign :: DsMonad q => Foreign -> q DForeign
dsForeign :: forall (q :: * -> *). DsMonad q => Foreign -> q DForeign
dsForeign (ImportF Callconv
cc Safety
safety String
str Name
n Type
ty) = Callconv -> Safety -> String -> Name -> DKind -> DForeign
DImportF Callconv
cc Safety
safety String
str Name
n (DKind -> DForeign) -> q DKind -> q DForeign
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
dsForeign (ExportF Callconv
cc String
str Name
n Type
ty) = Callconv -> String -> Name -> DKind -> DForeign
DExportF Callconv
cc String
str Name
n (DKind -> DForeign) -> q DKind -> q DForeign
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
dsPragma :: DsMonad q => Pragma -> q DPragma
dsPragma :: forall (q :: * -> *). DsMonad q => Pragma -> q DPragma
dsPragma (InlineP Name
n Inline
inl RuleMatch
rm Phases
phases) = DPragma -> q DPragma
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPragma -> q DPragma) -> DPragma -> q DPragma
forall a b. (a -> b) -> a -> b
$ Name -> Inline -> RuleMatch -> Phases -> DPragma
DInlineP Name
n Inline
inl RuleMatch
rm Phases
phases
dsPragma (SpecialiseP Name
n Type
ty Maybe Inline
m_inl Phases
phases) = Name -> DKind -> Maybe Inline -> Phases -> DPragma
DSpecialiseP Name
n (DKind -> Maybe Inline -> Phases -> DPragma)
-> q DKind -> q (Maybe Inline -> Phases -> DPragma)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
q (Maybe Inline -> Phases -> DPragma)
-> q (Maybe Inline) -> q (Phases -> DPragma)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Inline -> q (Maybe Inline)
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Inline
m_inl
q (Phases -> DPragma) -> q Phases -> q DPragma
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Phases -> q Phases
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Phases
phases
dsPragma (SpecialiseInstP Type
ty) = DKind -> DPragma
DSpecialiseInstP (DKind -> DPragma) -> q DKind -> q DPragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
#if __GLASGOW_HASKELL__ >= 807
dsPragma (RuleP String
str Maybe [TyVarBndrUnit]
mtvbs [RuleBndr]
rbs Exp
lhs Exp
rhs Phases
phases)
= String
-> Maybe [DTyVarBndrUnit]
-> [DRuleBndr]
-> DExp
-> DExp
-> Phases
-> DPragma
DRuleP String
str (Maybe [DTyVarBndrUnit]
-> [DRuleBndr] -> DExp -> DExp -> Phases -> DPragma)
-> q (Maybe [DTyVarBndrUnit])
-> q ([DRuleBndr] -> DExp -> DExp -> Phases -> DPragma)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([TyVarBndrUnit] -> q [DTyVarBndrUnit])
-> Maybe [TyVarBndrUnit] -> q (Maybe [DTyVarBndrUnit])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM ((TyVarBndrUnit -> q DTyVarBndrUnit)
-> [TyVarBndrUnit] -> q [DTyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrUnit -> q DTyVarBndrUnit
forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit) Maybe [TyVarBndrUnit]
mtvbs
q ([DRuleBndr] -> DExp -> DExp -> Phases -> DPragma)
-> q [DRuleBndr] -> q (DExp -> DExp -> Phases -> DPragma)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (RuleBndr -> q DRuleBndr) -> [RuleBndr] -> q [DRuleBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM RuleBndr -> q DRuleBndr
forall (q :: * -> *). DsMonad q => RuleBndr -> q DRuleBndr
dsRuleBndr [RuleBndr]
rbs
q (DExp -> DExp -> Phases -> DPragma)
-> q DExp -> q (DExp -> Phases -> DPragma)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
lhs
q (DExp -> Phases -> DPragma) -> q DExp -> q (Phases -> DPragma)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
rhs
q (Phases -> DPragma) -> q Phases -> q DPragma
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Phases -> q Phases
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Phases
phases
#else
dsPragma (RuleP str rbs lhs rhs phases) = DRuleP str Nothing
<$> mapM dsRuleBndr rbs
<*> dsExp lhs
<*> dsExp rhs
<*> pure phases
#endif
dsPragma (AnnP AnnTarget
target Exp
exp) = AnnTarget -> DExp -> DPragma
DAnnP AnnTarget
target (DExp -> DPragma) -> q DExp -> q DPragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsPragma (LineP Int
n String
str) = DPragma -> q DPragma
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPragma -> q DPragma) -> DPragma -> q DPragma
forall a b. (a -> b) -> a -> b
$ Int -> String -> DPragma
DLineP Int
n String
str
#if __GLASGOW_HASKELL__ >= 801
dsPragma (CompleteP [Name]
cls Maybe Name
mty) = DPragma -> q DPragma
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPragma -> q DPragma) -> DPragma -> q DPragma
forall a b. (a -> b) -> a -> b
$ [Name] -> Maybe Name -> DPragma
DCompleteP [Name]
cls Maybe Name
mty
#endif
#if __GLASGOW_HASKELL__ >= 903
dsPragma (OpaqueP Name
n) = DPragma -> q DPragma
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPragma -> q DPragma) -> DPragma -> q DPragma
forall a b. (a -> b) -> a -> b
$ Name -> DPragma
DOpaqueP Name
n
#endif
dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr
dsRuleBndr :: forall (q :: * -> *). DsMonad q => RuleBndr -> q DRuleBndr
dsRuleBndr (RuleVar Name
n) = DRuleBndr -> q DRuleBndr
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DRuleBndr -> q DRuleBndr) -> DRuleBndr -> q DRuleBndr
forall a b. (a -> b) -> a -> b
$ Name -> DRuleBndr
DRuleVar Name
n
dsRuleBndr (TypedRuleVar Name
n Type
ty) = Name -> DKind -> DRuleBndr
DTypedRuleVar Name
n (DKind -> DRuleBndr) -> q DKind -> q DRuleBndr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
#if __GLASGOW_HASKELL__ >= 807
dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn
dsTySynEqn :: forall (q :: * -> *). DsMonad q => Name -> TySynEqn -> q DTySynEqn
dsTySynEqn Name
_ (TySynEqn Maybe [TyVarBndrUnit]
mtvbs Type
lhs Type
rhs) =
Maybe [DTyVarBndrUnit] -> DKind -> DKind -> DTySynEqn
DTySynEqn (Maybe [DTyVarBndrUnit] -> DKind -> DKind -> DTySynEqn)
-> q (Maybe [DTyVarBndrUnit]) -> q (DKind -> DKind -> DTySynEqn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([TyVarBndrUnit] -> q [DTyVarBndrUnit])
-> Maybe [TyVarBndrUnit] -> q (Maybe [DTyVarBndrUnit])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM ((TyVarBndrUnit -> q DTyVarBndrUnit)
-> [TyVarBndrUnit] -> q [DTyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrUnit -> q DTyVarBndrUnit
forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit) Maybe [TyVarBndrUnit]
mtvbs q (DKind -> DKind -> DTySynEqn)
-> q DKind -> q (DKind -> DTySynEqn)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
lhs q (DKind -> DTySynEqn) -> q DKind -> q DTySynEqn
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
rhs
#else
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
dsClauses :: DsMonad q
=> MatchContext
-> [Clause]
-> q [DClause]
dsClauses :: forall (q :: * -> *).
DsMonad q =>
MatchContext -> [Clause] -> q [DClause]
dsClauses MatchContext
_ [] = [DClause] -> q [DClause]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
dsClauses MatchContext
mc (Clause [Pat]
pats (NormalB Exp
exp) [Dec]
where_decs : [Clause]
rest) = do
[DClause]
rest' <- MatchContext -> [Clause] -> q [DClause]
forall (q :: * -> *).
DsMonad q =>
MatchContext -> [Clause] -> q [DClause]
dsClauses MatchContext
mc [Clause]
rest
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
([DLetDec]
where_decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
where_decs
let exp_with_wheres :: DExp
exp_with_wheres = [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
where_decs' (DExp -> DExp
ip_binder DExp
exp')
([DPat]
pats', DExp
exp'') <- [Pat] -> DExp -> q ([DPat], DExp)
forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp [Pat]
pats DExp
exp_with_wheres
[DClause] -> q [DClause]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DClause] -> q [DClause]) -> [DClause] -> q [DClause]
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DClause
DClause [DPat]
pats' DExp
exp'' DClause -> [DClause] -> [DClause]
forall a. a -> [a] -> [a]
: [DClause]
rest'
dsClauses MatchContext
mc clauses :: [Clause]
clauses@(Clause [Pat]
outer_pats Body
_ [Dec]
_ : [Clause]
_) = do
[Name]
arg_names <- Int -> q Name -> q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Pat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
outer_pats) (String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"arg")
let scrutinee :: DExp
scrutinee = [DExp] -> DExp
mkUnboxedTupleDExp ((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 a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [DClause
clause]
where
clause_to_dmatch :: DsMonad q => DExp -> Clause -> [DMatch] -> q [DMatch]
clause_to_dmatch :: forall (q :: * -> *).
DsMonad q =>
DExp -> Clause -> [DMatch] -> q [DMatch]
clause_to_dmatch DExp
scrutinee (Clause [Pat]
pats Body
body [Dec]
where_decs) [DMatch]
failure_matches = do
let failure_exp :: DExp
failure_exp = MatchContext -> DExp -> [DMatch] -> DExp
maybeDCaseE MatchContext
mc DExp
scrutinee [DMatch]
failure_matches
DExp
exp <- Body -> [Dec] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody Body
body [Dec]
where_decs DExp
failure_exp
([DPat]
pats', DExp
exp') <- [Pat] -> DExp -> q ([DPat], DExp)
forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp [Pat]
pats DExp
exp
Bool
uni_pats <- (All -> Bool) -> q All -> q Bool
forall a b. (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap All -> Bool
getAll (q All -> q Bool) -> q All -> q Bool
forall a b. (a -> b) -> a -> b
$ (DPat -> q All) -> [DPat] -> q All
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM ((Bool -> All) -> q Bool -> q All
forall a b. (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> All
All (q Bool -> q All) -> (DPat -> q Bool) -> DPat -> q All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern) [DPat]
pats'
let match :: DMatch
match = DPat -> DExp -> DMatch
DMatch ([DPat] -> DPat
mkUnboxedTupleDPat [DPat]
pats') DExp
exp'
if Bool
uni_pats
then [DMatch] -> q [DMatch]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [DMatch
match]
else [DMatch] -> q [DMatch]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DMatch
match DMatch -> [DMatch] -> [DMatch]
forall a. a -> [a] -> [a]
: [DMatch]
failure_matches)
data MatchContext
= FunRhs Name
| LetDecRhs Pat
| RecUpd
| MultiWayIfAlt
| CaseAlt
mkErrorMatchExpr :: MatchContext -> DExp
mkErrorMatchExpr :: MatchContext -> DExp
mkErrorMatchExpr MatchContext
mc =
DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'error) (Lit -> DExp
DLitE (String -> Lit
StringL (String
"Non-exhaustive patterns in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pp_context)))
where
pp_context :: String
pp_context =
case MatchContext
mc of
FunRhs Name
n -> Name -> String
forall a. Show a => a -> String
show Name
n
LetDecRhs Pat
pat -> Pat -> String
forall a. Ppr a => a -> String
pprint Pat
pat
MatchContext
RecUpd -> String
"record update"
MatchContext
MultiWayIfAlt -> String
"multi-way if"
MatchContext
CaseAlt -> String
"case"
dsType :: DsMonad q => Type -> q DType
#if __GLASGOW_HASKELL__ >= 900
dsType :: forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType (Type
MulArrowT `AppT` Type
_) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DKind
DArrowT
dsType Type
MulArrowT = String -> q DKind
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot desugar exotic uses of linear types."
#endif
dsType (ForallT [TyVarBndr Specificity]
tvbs [Type]
preds Type
ty) =
DForallTelescope -> [DKind] -> DKind -> DKind
mkDForallConstrainedT (DForallTelescope -> [DKind] -> DKind -> DKind)
-> q DForallTelescope -> q ([DKind] -> DKind -> DKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DTyVarBndrSpec] -> DForallTelescope
DForallInvis ([DTyVarBndrSpec] -> DForallTelescope)
-> q [DTyVarBndrSpec] -> q DForallTelescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr Specificity -> q DTyVarBndrSpec)
-> [TyVarBndr Specificity] -> q [DTyVarBndrSpec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndr Specificity -> q DTyVarBndrSpec
forall (q :: * -> *).
DsMonad q =>
TyVarBndr Specificity -> q DTyVarBndrSpec
dsTvbSpec [TyVarBndr Specificity]
tvbs)
q ([DKind] -> DKind -> DKind) -> q [DKind] -> q (DKind -> DKind)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
preds q (DKind -> DKind) -> q DKind -> q DKind
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
dsType (AppT Type
t1 Type
t2) = DKind -> DKind -> DKind
DAppT (DKind -> DKind -> DKind) -> q DKind -> q (DKind -> DKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t1 q (DKind -> DKind) -> q DKind -> q DKind
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t2
dsType (SigT Type
ty Type
ki) = DKind -> DKind -> DKind
DSigT (DKind -> DKind -> DKind) -> q DKind -> q (DKind -> DKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty q (DKind -> DKind) -> q DKind -> q DKind
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ki
dsType (VarT Name
name) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DVarT Name
name
dsType (ConT Name
name) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT Name
name
dsType (PromotedT Name
name) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT Name
name
dsType (TupleT Int
n) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT (Int -> Name
tupleTypeName Int
n)
dsType (UnboxedTupleT Int
n) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT (Int -> Name
unboxedTupleTypeName Int
n)
dsType Type
ArrowT = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DKind
DArrowT
dsType Type
ListT = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT ''[]
dsType (PromotedTupleT Int
n) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT (Int -> Name
tupleDataName Int
n)
dsType Type
PromotedNilT = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT '[]
dsType Type
PromotedConsT = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT '(:)
dsType Type
StarT = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT Name
typeKindName
dsType Type
ConstraintT = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT ''Constraint
dsType (LitT TyLit
lit) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ TyLit -> DKind
DLitT TyLit
lit
dsType Type
EqualityT = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT ''(~)
dsType (InfixT Type
t1 Name
n Type
t2) = Type -> Name -> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> Name -> Type -> q DKind
dsInfixT Type
t1 Name
n Type
t2
dsType (UInfixT{}) = q DKind
forall (m :: * -> *) a. MonadFail m => m a
dsUInfixT
dsType (ParensT Type
t) = Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t
dsType Type
WildCardT = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DKind
DWildCardT
#if __GLASGOW_HASKELL__ >= 801
dsType (UnboxedSumT Int
arity) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT (Int -> Name
unboxedSumTypeName Int
arity)
#endif
#if __GLASGOW_HASKELL__ >= 807
dsType (AppKindT Type
t Type
k) = DKind -> DKind -> DKind
DAppKindT (DKind -> DKind -> DKind) -> q DKind -> q (DKind -> DKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t q (DKind -> DKind) -> q DKind -> q DKind
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
k
dsType (ImplicitParamT String
n Type
t) = do
DKind
t' <- Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t
DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT ''IP DKind -> DKind -> DKind
`DAppT` TyLit -> DKind
DLitT (String -> TyLit
StrTyLit String
n) DKind -> DKind -> DKind
`DAppT` DKind
t'
#endif
#if __GLASGOW_HASKELL__ >= 809
dsType (ForallVisT [TyVarBndrUnit]
tvbs Type
ty) =
DForallTelescope -> DKind -> DKind
DForallT (DForallTelescope -> DKind -> DKind)
-> q DForallTelescope -> q (DKind -> DKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DTyVarBndrUnit] -> DForallTelescope
DForallVis ([DTyVarBndrUnit] -> DForallTelescope)
-> q [DTyVarBndrUnit] -> q DForallTelescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndrUnit -> q DTyVarBndrUnit)
-> [TyVarBndrUnit] -> q [DTyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrUnit -> q DTyVarBndrUnit
forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit [TyVarBndrUnit]
tvbs) q (DKind -> DKind) -> q DKind -> q DKind
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
#endif
#if __GLASGOW_HASKELL__ >= 903
dsType (PromotedInfixT Type
t1 Name
n Type
t2) = Type -> Name -> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> Name -> Type -> q DKind
dsInfixT Type
t1 Name
n Type
t2
dsType PromotedUInfixT{} = q DKind
forall (m :: * -> *) a. MonadFail m => m a
dsUInfixT
#endif
#if __GLASGOW_HASKELL__ >= 900
dsTvb :: DsMonad q => TyVarBndr_ flag -> q (DTyVarBndr flag)
dsTvb :: forall (q :: * -> *) flag.
DsMonad q =>
TyVarBndr_ flag -> q (DTyVarBndr flag)
dsTvb (PlainTV Name
n flag
flag) = DTyVarBndr flag -> q (DTyVarBndr flag)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DTyVarBndr flag -> q (DTyVarBndr flag))
-> DTyVarBndr flag -> q (DTyVarBndr flag)
forall a b. (a -> b) -> a -> b
$ Name -> flag -> DTyVarBndr flag
forall flag. Name -> flag -> DTyVarBndr flag
DPlainTV Name
n flag
flag
dsTvb (KindedTV Name
n flag
flag Type
k) = Name -> flag -> DKind -> DTyVarBndr flag
forall flag. Name -> flag -> DKind -> DTyVarBndr flag
DKindedTV Name
n flag
flag (DKind -> DTyVarBndr flag) -> q DKind -> q (DTyVarBndr flag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
k
#else
dsTvb :: DsMonad q => flag -> TyVarBndr -> q (DTyVarBndr flag)
dsTvb flag (PlainTV n) = return $ DPlainTV n flag
dsTvb flag (KindedTV n k) = DKindedTV n flag <$> dsType k
#endif
dsInfixT :: DsMonad q => Type -> Name -> Type -> q DType
dsInfixT :: forall (q :: * -> *). DsMonad q => Type -> Name -> Type -> q DKind
dsInfixT Type
t1 Name
n Type
t2 = DKind -> DKind -> DKind
DAppT (DKind -> DKind -> DKind) -> q DKind -> q (DKind -> DKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DKind -> DKind -> DKind
DAppT (Name -> DKind
DConT Name
n) (DKind -> DKind) -> q DKind -> q DKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t1) q (DKind -> DKind) -> q DKind -> q DKind
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t2
dsUInfixT :: Fail.MonadFail m => m a
dsUInfixT :: forall (m :: * -> *) a. MonadFail m => m a
dsUInfixT = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot desugar unresolved infix operators."
dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec
#if __GLASGOW_HASKELL__ >= 900
dsTvbSpec :: forall (q :: * -> *).
DsMonad q =>
TyVarBndr Specificity -> q DTyVarBndrSpec
dsTvbSpec = TyVarBndr Specificity -> q DTyVarBndrSpec
forall (q :: * -> *) flag.
DsMonad q =>
TyVarBndr_ flag -> q (DTyVarBndr flag)
dsTvb
#else
dsTvbSpec = dsTvb SpecifiedSpec
#endif
dsTvbUnit :: DsMonad q => TyVarBndrUnit -> q DTyVarBndrUnit
#if __GLASGOW_HASKELL__ >= 900
dsTvbUnit :: forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit = TyVarBndrUnit -> q DTyVarBndrUnit
forall (q :: * -> *) flag.
DsMonad q =>
TyVarBndr_ flag -> q (DTyVarBndr flag)
dsTvb
#else
dsTvbUnit = dsTvb ()
#endif
dsCxt :: DsMonad q => Cxt -> q DCxt
dsCxt :: forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt = (Type -> q [DKind]) -> [Type] -> q [DKind]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Type -> q [DKind]
forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred
#if __GLASGOW_HASKELL__ >= 801
type DerivingClause = DerivClause
dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause
dsDerivClause :: forall (q :: * -> *). DsMonad q => DerivClause -> q DDerivClause
dsDerivClause (DerivClause Maybe DerivStrategy
mds [Type]
cxt) =
Maybe DDerivStrategy -> [DKind] -> DDerivClause
DDerivClause (Maybe DDerivStrategy -> [DKind] -> DDerivClause)
-> q (Maybe DDerivStrategy) -> q ([DKind] -> DDerivClause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DerivStrategy -> q DDerivStrategy)
-> Maybe DerivStrategy -> q (Maybe DDerivStrategy)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM DerivStrategy -> q DDerivStrategy
forall (q :: * -> *).
DsMonad q =>
DerivStrategy -> q DDerivStrategy
dsDerivStrategy Maybe DerivStrategy
mds q ([DKind] -> DDerivClause) -> q [DKind] -> q DDerivClause
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt
#else
type DerivingClause = Pred
dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause
dsDerivClause p = DDerivClause Nothing <$> dsPred p
#endif
#if __GLASGOW_HASKELL__ >= 801
dsDerivStrategy :: DsMonad q => DerivStrategy -> q DDerivStrategy
dsDerivStrategy :: forall (q :: * -> *).
DsMonad q =>
DerivStrategy -> q DDerivStrategy
dsDerivStrategy DerivStrategy
StockStrategy = DDerivStrategy -> q DDerivStrategy
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DStockStrategy
dsDerivStrategy DerivStrategy
AnyclassStrategy = DDerivStrategy -> q DDerivStrategy
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DAnyclassStrategy
dsDerivStrategy DerivStrategy
NewtypeStrategy = DDerivStrategy -> q DDerivStrategy
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DNewtypeStrategy
#if __GLASGOW_HASKELL__ >= 805
dsDerivStrategy (ViaStrategy Type
ty) = DKind -> DDerivStrategy
DViaStrategy (DKind -> DDerivStrategy) -> q DKind -> q DDerivStrategy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
#endif
#endif
#if __GLASGOW_HASKELL__ >= 801
dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir
dsPatSynDir :: forall (q :: * -> *).
DsMonad q =>
Name -> PatSynDir -> q DPatSynDir
dsPatSynDir Name
_ PatSynDir
Unidir = DPatSynDir -> q DPatSynDir
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DPatSynDir
DUnidir
dsPatSynDir Name
_ PatSynDir
ImplBidir = DPatSynDir -> q DPatSynDir
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DPatSynDir
DImplBidir
dsPatSynDir Name
n (ExplBidir [Clause]
clauses) = [DClause] -> DPatSynDir
DExplBidir ([DClause] -> DPatSynDir) -> q [DClause] -> q DPatSynDir
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MatchContext -> [Clause] -> q [DClause]
forall (q :: * -> *).
DsMonad q =>
MatchContext -> [Clause] -> q [DClause]
dsClauses (Name -> MatchContext
FunRhs Name
n) [Clause]
clauses
#endif
dsPred :: DsMonad q => Pred -> q DCxt
dsPred :: forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
t
| Just [Type]
ts <- Type -> Maybe [Type]
splitTuple_maybe Type
t
= (Type -> q [DKind]) -> [Type] -> q [DKind]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Type -> q [DKind]
forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred [Type]
ts
dsPred (ForallT [TyVarBndr Specificity]
tvbs [Type]
cxt Type
p) = [TyVarBndr Specificity] -> [Type] -> Type -> q [DKind]
forall (q :: * -> *).
DsMonad q =>
[TyVarBndr Specificity] -> [Type] -> Type -> q [DKind]
dsForallPred [TyVarBndr Specificity]
tvbs [Type]
cxt Type
p
dsPred (AppT Type
t1 Type
t2) = do
[DKind
p1] <- Type -> q [DKind]
forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
t1
(DKind -> [DKind] -> [DKind]
forall a. a -> [a] -> [a]
:[]) (DKind -> [DKind]) -> (DKind -> DKind) -> DKind -> [DKind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DKind -> DKind -> DKind
DAppT DKind
p1 (DKind -> [DKind]) -> q DKind -> q [DKind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t2
dsPred (SigT Type
ty Type
ki) = do
[DKind]
preds <- Type -> q [DKind]
forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
ty
case [DKind]
preds of
[DKind
p] -> (DKind -> [DKind] -> [DKind]
forall a. a -> [a] -> [a]
:[]) (DKind -> [DKind]) -> (DKind -> DKind) -> DKind -> [DKind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DKind -> DKind -> DKind
DSigT DKind
p (DKind -> [DKind]) -> q DKind -> q [DKind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ki
[DKind]
other -> [DKind] -> q [DKind]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [DKind]
other
dsPred (VarT Name
n) = [DKind] -> q [DKind]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DKind
DVarT Name
n]
dsPred (ConT Name
n) = [DKind] -> q [DKind]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DKind
DConT Name
n]
dsPred t :: Type
t@(PromotedT Name
_) =
String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q [DKind]) -> String -> q [DKind]
forall a b. (a -> b) -> a -> b
$ String
"Promoted type seen as head of constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
dsPred (TupleT Int
0) = [DKind] -> q [DKind]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DKind
DConT (Int -> Name
tupleTypeName Int
0)]
dsPred (TupleT Int
_) =
String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Internal error in th-desugar in detecting tuple constraints."
dsPred t :: Type
t@(UnboxedTupleT Int
_) =
String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q [DKind]) -> String -> q [DKind]
forall a b. (a -> b) -> a -> b
$ String
"Unboxed tuple seen as head of constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
dsPred Type
ArrowT = String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Arrow seen as head of constraint."
dsPred Type
ListT = String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"List seen as head of constraint."
dsPred (PromotedTupleT Int
_) =
String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Promoted tuple seen as head of constraint."
dsPred Type
PromotedNilT = String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Promoted nil seen as head of constraint."
dsPred Type
PromotedConsT = String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Promoted cons seen as head of constraint."
dsPred Type
StarT = String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"* seen as head of constraint."
dsPred Type
ConstraintT =
String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"The kind `Constraint' seen as head of constraint."
dsPred t :: Type
t@(LitT TyLit
_) =
String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q [DKind]) -> String -> q [DKind]
forall a b. (a -> b) -> a -> b
$ String
"Type literal seen as head of constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
dsPred Type
EqualityT = [DKind] -> q [DKind]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DKind
DConT ''(~)]
dsPred (InfixT Type
t1 Name
n Type
t2) = (DKind -> [DKind] -> [DKind]
forall a. a -> [a] -> [a]
:[]) (DKind -> [DKind]) -> q DKind -> q [DKind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Name -> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> Name -> Type -> q DKind
dsInfixT Type
t1 Name
n Type
t2
dsPred (UInfixT{}) = q [DKind]
forall (m :: * -> *) a. MonadFail m => m a
dsUInfixT
dsPred (ParensT Type
t) = Type -> q [DKind]
forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
t
dsPred Type
WildCardT = [DKind] -> q [DKind]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [DKind
DWildCardT]
#if __GLASGOW_HASKELL__ >= 801
dsPred t :: Type
t@(UnboxedSumT {}) =
String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q [DKind]) -> String -> q [DKind]
forall a b. (a -> b) -> a -> b
$ String
"Unboxed sum seen as head of constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
#endif
#if __GLASGOW_HASKELL__ >= 807
dsPred (AppKindT Type
t Type
k) = do
[DKind
p] <- Type -> q [DKind]
forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
t
(DKind -> [DKind] -> [DKind]
forall a. a -> [a] -> [a]
:[]) (DKind -> [DKind]) -> q DKind -> q [DKind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DKind -> DKind -> DKind
DAppKindT DKind
p (DKind -> DKind) -> q DKind -> q DKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
k)
dsPred (ImplicitParamT String
n Type
t) = do
DKind
t' <- Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t
[DKind] -> q [DKind]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DKind
DConT ''IP DKind -> DKind -> DKind
`DAppT` TyLit -> DKind
DLitT (String -> TyLit
StrTyLit String
n) DKind -> DKind -> DKind
`DAppT` DKind
t']
#endif
#if __GLASGOW_HASKELL__ >= 809
dsPred t :: Type
t@(ForallVisT {}) =
String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q [DKind]) -> String -> q [DKind]
forall a b. (a -> b) -> a -> b
$ String
"Visible dependent quantifier seen as head of constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
#endif
#if __GLASGOW_HASKELL__ >= 900
dsPred Type
MulArrowT = String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Linear arrow seen as head of constraint."
#endif
#if __GLASGOW_HASKELL__ >= 903
dsPred t :: Type
t@PromotedInfixT{} =
String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q [DKind]) -> String -> q [DKind]
forall a b. (a -> b) -> a -> b
$ String
"Promoted infix type seen as head of constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
dsPred PromotedUInfixT{} = q [DKind]
forall (m :: * -> *) a. MonadFail m => m a
dsUInfixT
#endif
dsForallPred :: DsMonad q => [TyVarBndrSpec] -> Cxt -> Pred -> q DCxt
dsForallPred :: forall (q :: * -> *).
DsMonad q =>
[TyVarBndr Specificity] -> [Type] -> Type -> q [DKind]
dsForallPred [TyVarBndr Specificity]
tvbs [Type]
cxt Type
p = do
[DKind]
ps' <- Type -> q [DKind]
forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
p
case [DKind]
ps' of
[DKind
p'] -> (DKind -> [DKind] -> [DKind]
forall a. a -> [a] -> [a]
:[]) (DKind -> [DKind]) -> q DKind -> q [DKind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DForallTelescope -> [DKind] -> DKind -> DKind
mkDForallConstrainedT (DForallTelescope -> [DKind] -> DKind -> DKind)
-> q DForallTelescope -> q ([DKind] -> DKind -> DKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
([DTyVarBndrSpec] -> DForallTelescope
DForallInvis ([DTyVarBndrSpec] -> DForallTelescope)
-> q [DTyVarBndrSpec] -> q DForallTelescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr Specificity -> q DTyVarBndrSpec)
-> [TyVarBndr Specificity] -> q [DTyVarBndrSpec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndr Specificity -> q DTyVarBndrSpec
forall (q :: * -> *).
DsMonad q =>
TyVarBndr Specificity -> q DTyVarBndrSpec
dsTvbSpec [TyVarBndr Specificity]
tvbs) q ([DKind] -> DKind -> DKind) -> q [DKind] -> q (DKind -> DKind)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt q (DKind -> DKind) -> q DKind -> q DKind
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DKind -> q DKind
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DKind
p')
[DKind]
_ -> String -> q [DKind]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot desugar constraint tuples in the body of a quantified constraint"
dsReify :: DsMonad q => Name -> q (Maybe DInfo)
dsReify :: forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReify = (Info -> q DInfo) -> Maybe Info -> q (Maybe DInfo)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Info -> q DInfo
forall (q :: * -> *). DsMonad q => Info -> q DInfo
dsInfo (Maybe Info -> q (Maybe DInfo))
-> (Name -> q (Maybe Info)) -> Name -> q (Maybe DInfo)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> q (Maybe Info)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Info)
reifyWithLocals_maybe
dsReifyType :: DsMonad q => Name -> q (Maybe DType)
dsReifyType :: forall (q :: * -> *). DsMonad q => Name -> q (Maybe DKind)
dsReifyType = (Type -> q DKind) -> Maybe Type -> q (Maybe DKind)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType (Maybe Type -> q (Maybe DKind))
-> (Name -> q (Maybe Type)) -> Name -> q (Maybe DKind)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> q (Maybe Type)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Type)
reifyTypeWithLocals_maybe
mkDForallConstrainedT :: DForallTelescope -> DCxt -> DType -> DType
mkDForallConstrainedT :: DForallTelescope -> [DKind] -> DKind -> DKind
mkDForallConstrainedT DForallTelescope
tele [DKind]
ctxt DKind
ty =
DForallTelescope -> DKind -> DKind
DForallT DForallTelescope
tele (DKind -> DKind) -> DKind -> DKind
forall a b. (a -> b) -> a -> b
$ if [DKind] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DKind]
ctxt then DKind
ty else [DKind] -> DKind -> DKind
DConstrainedT [DKind]
ctxt DKind
ty
reorderFields :: DsMonad q => Name -> [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp]
reorderFields :: forall (q :: * -> *).
DsMonad q =>
Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
reorderFields = (Exp -> q DExp)
-> Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
forall (m :: * -> *) a da.
(Applicative m, MonadFail m) =>
(a -> m da)
-> Name -> [VarBangType] -> [(Name, a)] -> [da] -> m [da]
reorderFields' Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp
reorderFieldsPat :: DsMonad q => Name -> [VarStrictType] -> [FieldPat] -> PatM q [DPat]
reorderFieldsPat :: forall (q :: * -> *).
DsMonad q =>
Name -> [VarBangType] -> [FieldPat] -> PatM q [DPat]
reorderFieldsPat Name
con_name [VarBangType]
field_decs [FieldPat]
field_pats =
(Pat -> WriterT [(Name, DExp)] q DPat)
-> Name
-> [VarBangType]
-> [FieldPat]
-> [DPat]
-> WriterT [(Name, DExp)] q [DPat]
forall (m :: * -> *) a da.
(Applicative m, MonadFail m) =>
(a -> m da)
-> Name -> [VarBangType] -> [(Name, a)] -> [da] -> m [da]
reorderFields' Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Name
con_name [VarBangType]
field_decs [FieldPat]
field_pats (DPat -> [DPat]
forall a. a -> [a]
repeat DPat
DWildP)
reorderFields' :: (Applicative m, Fail.MonadFail m)
=> (a -> m da)
-> Name
-> [VarStrictType] -> [(Name, a)]
-> [da] -> m [da]
reorderFields' :: forall (m :: * -> *) a da.
(Applicative m, MonadFail m) =>
(a -> m da)
-> Name -> [VarBangType] -> [(Name, a)] -> [da] -> m [da]
reorderFields' a -> m da
ds_thing Name
con_name [VarBangType]
field_names_types [(Name, a)]
field_things [da]
deflts =
m ()
check_valid_fields m () -> m [da] -> m [da]
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Name] -> [da] -> m [da]
reorder [Name]
field_names [da]
deflts
where
field_names :: [Name]
field_names = (VarBangType -> Name) -> [VarBangType] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
a, Bang
_, Type
_) -> Name
a) [VarBangType]
field_names_types
check_valid_fields :: m ()
check_valid_fields =
[(Name, a)] -> ((Name, a) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Name, a)]
field_things (((Name, a) -> m ()) -> m ()) -> ((Name, a) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Name
thing_name, a
_) ->
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name
thing_name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
field_names) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Constructor ‘" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
con_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"‘ does not have field ‘"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
thing_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"‘"
reorder :: [Name] -> [da] -> m [da]
reorder [] [da]
_ = [da] -> m [da]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
reorder (Name
field_name : [Name]
rest) (da
deflt : [da]
rest_deflt) = do
[da]
rest' <- [Name] -> [da] -> m [da]
reorder [Name]
rest [da]
rest_deflt
case ((Name, a) -> Bool) -> [(Name, a)] -> Maybe (Name, a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Name
thing_name, a
_) -> Name
thing_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
field_name) [(Name, a)]
field_things of
Just (Name
_, a
thing) -> (da -> [da] -> [da]
forall a. a -> [a] -> [a]
: [da]
rest') (da -> [da]) -> m da -> m [da]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m da
ds_thing a
thing
Maybe (Name, a)
Nothing -> [da] -> m [da]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([da] -> m [da]) -> [da] -> m [da]
forall a b. (a -> b) -> a -> b
$ da
deflt da -> [da] -> [da]
forall a. a -> [a] -> [a]
: [da]
rest'
reorder (Name
_ : [Name]
_) [] = String -> m [da]
forall a. HasCallStack => String -> a
error String
"Internal error in th-desugar."
mkTupleDExp :: [DExp] -> DExp
mkTupleDExp :: [DExp] -> DExp
mkTupleDExp [DExp
exp] = DExp
exp
mkTupleDExp [DExp]
exps = (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE (Name -> DExp) -> Name -> DExp
forall a b. (a -> b) -> a -> b
$ Int -> Name
tupleDataName ([DExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
exps)) [DExp]
exps
mkUnboxedTupleDExp :: [DExp] -> DExp
mkUnboxedTupleDExp :: [DExp] -> DExp
mkUnboxedTupleDExp [DExp
exp] = DExp
exp
mkUnboxedTupleDExp [DExp]
exps = (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE (Name -> DExp) -> Name -> DExp
forall a b. (a -> b) -> a -> b
$ Int -> Name
unboxedTupleDataName ([DExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
exps)) [DExp]
exps
mkTupleExp :: [Exp] -> Exp
mkTupleExp :: [Exp] -> Exp
mkTupleExp [Exp
exp] = Exp
exp
mkTupleExp [Exp]
exps = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Name
tupleDataName ([Exp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp]
exps)) [Exp]
exps
mkUnboxedTupleExp :: [Exp] -> Exp
mkUnboxedTupleExp :: [Exp] -> Exp
mkUnboxedTupleExp [Exp
exp] = Exp
exp
mkUnboxedTupleExp [Exp]
exps = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Name
unboxedTupleDataName ([Exp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp]
exps)) [Exp]
exps
mkTupleDPat :: [DPat] -> DPat
mkTupleDPat :: [DPat] -> DPat
mkTupleDPat [DPat
pat] = DPat
pat
mkTupleDPat [DPat]
pats = Name -> [DKind] -> [DPat] -> DPat
DConP (Int -> Name
tupleDataName ([DPat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DPat]
pats)) [] [DPat]
pats
mkUnboxedTupleDPat :: [DPat] -> DPat
mkUnboxedTupleDPat :: [DPat] -> DPat
mkUnboxedTupleDPat [DPat
pat] = DPat
pat
mkUnboxedTupleDPat [DPat]
pats = Name -> [DKind] -> [DPat] -> DPat
DConP (Int -> Name
unboxedTupleDataName ([DPat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DPat]
pats)) [] [DPat]
pats
isUniversalPattern :: DsMonad q => DPat -> q Bool
isUniversalPattern :: forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern (DLitP {}) = Bool -> q Bool
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isUniversalPattern (DVarP {}) = Bool -> q Bool
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isUniversalPattern (DConP Name
con_name [DKind]
_ [DPat]
pats) = do
Name
data_name <- Name -> q Name
forall (q :: * -> *). DsMonad q => Name -> q Name
dataConNameToDataName Name
con_name
(DataFlavor
_df, [TyVarBndrUnit]
_tvbs, [Con]
cons) <- String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])
forall (q :: * -> *).
DsMonad q =>
String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])
getDataD String
"Internal error." Name
data_name
if [Con] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
then ([Bool] -> Bool) -> q [Bool] -> q Bool
forall a b. (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (q [Bool] -> q Bool) -> q [Bool] -> q Bool
forall a b. (a -> b) -> a -> b
$ (DPat -> q Bool) -> [DPat] -> q [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern [DPat]
pats
else Bool -> q Bool
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isUniversalPattern (DTildeP {}) = Bool -> q Bool
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isUniversalPattern (DBangP DPat
pat) = DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
pat
isUniversalPattern (DSigP DPat
pat DKind
_) = DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
pat
isUniversalPattern DPat
DWildP = Bool -> q Bool
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
applyDExp :: DExp -> [DExp] -> DExp
applyDExp :: DExp -> [DExp] -> DExp
applyDExp = (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE
applyDType :: DType -> [DTypeArg] -> DType
applyDType :: DKind -> [DTypeArg] -> DKind
applyDType = (DKind -> DTypeArg -> DKind) -> DKind -> [DTypeArg] -> DKind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DKind -> DTypeArg -> DKind
apply
where
apply :: DType -> DTypeArg -> DType
apply :: DKind -> DTypeArg -> DKind
apply DKind
f (DTANormal DKind
x) = DKind
f DKind -> DKind -> DKind
`DAppT` DKind
x
apply DKind
f (DTyArg DKind
x) = DKind
f DKind -> DKind -> DKind
`DAppKindT` DKind
x
data DTypeArg
= DTANormal DType
| DTyArg DKind
deriving (DTypeArg -> DTypeArg -> Bool
(DTypeArg -> DTypeArg -> Bool)
-> (DTypeArg -> DTypeArg -> Bool) -> Eq DTypeArg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DTypeArg -> DTypeArg -> Bool
== :: DTypeArg -> DTypeArg -> Bool
$c/= :: DTypeArg -> DTypeArg -> Bool
/= :: DTypeArg -> DTypeArg -> Bool
Eq, Int -> DTypeArg -> String -> String
[DTypeArg] -> String -> String
DTypeArg -> String
(Int -> DTypeArg -> String -> String)
-> (DTypeArg -> String)
-> ([DTypeArg] -> String -> String)
-> Show DTypeArg
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DTypeArg -> String -> String
showsPrec :: Int -> DTypeArg -> String -> String
$cshow :: DTypeArg -> String
show :: DTypeArg -> String
$cshowList :: [DTypeArg] -> String -> String
showList :: [DTypeArg] -> String -> String
Show, Typeable DTypeArg
Typeable DTypeArg =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DTypeArg -> c DTypeArg)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DTypeArg)
-> (DTypeArg -> Constr)
-> (DTypeArg -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DTypeArg))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DTypeArg))
-> ((forall b. Data b => b -> b) -> DTypeArg -> DTypeArg)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r)
-> (forall u. (forall d. Data d => d -> u) -> DTypeArg -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> DTypeArg -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg)
-> Data DTypeArg
DTypeArg -> Constr
DTypeArg -> DataType
(forall b. Data b => b -> b) -> DTypeArg -> DTypeArg
forall a.
Typeable a =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> DTypeArg -> u
forall u. (forall d. Data d => d -> u) -> DTypeArg -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DTypeArg
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DTypeArg -> c DTypeArg
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DTypeArg)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DTypeArg)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DTypeArg -> c DTypeArg
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DTypeArg -> c DTypeArg
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DTypeArg
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DTypeArg
$ctoConstr :: DTypeArg -> Constr
toConstr :: DTypeArg -> Constr
$cdataTypeOf :: DTypeArg -> DataType
dataTypeOf :: DTypeArg -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DTypeArg)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DTypeArg)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DTypeArg)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DTypeArg)
$cgmapT :: (forall b. Data b => b -> b) -> DTypeArg -> DTypeArg
gmapT :: (forall b. Data b => b -> b) -> DTypeArg -> DTypeArg
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DTypeArg -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> DTypeArg -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DTypeArg -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DTypeArg -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
Data, (forall x. DTypeArg -> Rep DTypeArg x)
-> (forall x. Rep DTypeArg x -> DTypeArg) -> Generic DTypeArg
forall x. Rep DTypeArg x -> DTypeArg
forall x. DTypeArg -> Rep DTypeArg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DTypeArg -> Rep DTypeArg x
from :: forall x. DTypeArg -> Rep DTypeArg x
$cto :: forall x. Rep DTypeArg x -> DTypeArg
to :: forall x. Rep DTypeArg x -> DTypeArg
Generic)
dsTypeArg :: DsMonad q => TypeArg -> q DTypeArg
dsTypeArg :: forall (q :: * -> *). DsMonad q => TypeArg -> q DTypeArg
dsTypeArg (TANormal Type
t) = DKind -> DTypeArg
DTANormal (DKind -> DTypeArg) -> q DKind -> q DTypeArg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t
dsTypeArg (TyArg Type
k) = DKind -> DTypeArg
DTyArg (DKind -> DTypeArg) -> q DKind -> q DTypeArg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
k
filterDTANormals :: [DTypeArg] -> [DType]
filterDTANormals :: [DTypeArg] -> [DKind]
filterDTANormals = (DTypeArg -> Maybe DKind) -> [DTypeArg] -> [DKind]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DTypeArg -> Maybe DKind
getDTANormal
where
getDTANormal :: DTypeArg -> Maybe DType
getDTANormal :: DTypeArg -> Maybe DKind
getDTANormal (DTANormal DKind
t) = DKind -> Maybe DKind
forall a. a -> Maybe a
Just DKind
t
getDTANormal (DTyArg {}) = Maybe DKind
forall a. Maybe a
Nothing
dTyVarBndrToDType :: DTyVarBndr flag -> DType
dTyVarBndrToDType :: forall flag. DTyVarBndr flag -> DKind
dTyVarBndrToDType (DPlainTV Name
a flag
_) = Name -> DKind
DVarT Name
a
dTyVarBndrToDType (DKindedTV Name
a flag
_ DKind
k) = Name -> DKind
DVarT Name
a DKind -> DKind -> DKind
`DSigT` DKind
k
probablyWrongUnDTypeArg :: DTypeArg -> DType
probablyWrongUnDTypeArg :: DTypeArg -> DKind
probablyWrongUnDTypeArg (DTANormal DKind
t) = DKind
t
probablyWrongUnDTypeArg (DTyArg DKind
k) = DKind
k
nonFamilyDataReturnType :: Name -> [DTyVarBndrUnit] -> DType
nonFamilyDataReturnType :: Name -> [DTyVarBndrUnit] -> DKind
nonFamilyDataReturnType Name
con_name =
DKind -> [DTypeArg] -> DKind
applyDType (Name -> DKind
DConT Name
con_name) ([DTypeArg] -> DKind)
-> ([DTyVarBndrUnit] -> [DTypeArg]) -> [DTyVarBndrUnit] -> DKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DTyVarBndrUnit -> DTypeArg) -> [DTyVarBndrUnit] -> [DTypeArg]
forall a b. (a -> b) -> [a] -> [b]
map (DKind -> DTypeArg
DTANormal (DKind -> DTypeArg)
-> (DTyVarBndrUnit -> DKind) -> DTyVarBndrUnit -> DTypeArg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DTyVarBndrUnit -> DKind
forall flag. DTyVarBndr flag -> DKind
dTyVarBndrToDType)
dataFamInstReturnType :: Name -> [DTypeArg] -> DType
dataFamInstReturnType :: Name -> [DTypeArg] -> DKind
dataFamInstReturnType Name
fam_name = DKind -> [DTypeArg] -> DKind
applyDType (Name -> DKind
DConT Name
fam_name)
dataFamInstTvbs :: [DTypeArg] -> [DTyVarBndrUnit]
dataFamInstTvbs :: [DTypeArg] -> [DTyVarBndrUnit]
dataFamInstTvbs = [DKind] -> [DTyVarBndrUnit]
toposortTyVarsOf ([DKind] -> [DTyVarBndrUnit])
-> ([DTypeArg] -> [DKind]) -> [DTypeArg] -> [DTyVarBndrUnit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DTypeArg -> DKind) -> [DTypeArg] -> [DKind]
forall a b. (a -> b) -> [a] -> [b]
map DTypeArg -> DKind
probablyWrongUnDTypeArg
toposortTyVarsOf :: [DType] -> [DTyVarBndrUnit]
toposortTyVarsOf :: [DKind] -> [DTyVarBndrUnit]
toposortTyVarsOf [DKind]
tys =
let freeVars :: [Name]
freeVars :: [Name]
freeVars = OSet Name -> [Name]
forall a. OSet a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (OSet Name -> [Name]) -> OSet Name -> [Name]
forall a b. (a -> b) -> a -> b
$ (DKind -> OSet Name) -> [DKind] -> OSet Name
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DKind -> OSet Name
fvDType [DKind]
tys
varKindSigs :: Map Name DKind
varKindSigs :: Map Name DKind
varKindSigs = (DKind -> Map Name DKind) -> [DKind] -> Map Name DKind
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DKind -> Map Name DKind
go_ty [DKind]
tys
where
go_ty :: DType -> Map Name DKind
go_ty :: DKind -> Map Name DKind
go_ty (DForallT DForallTelescope
tele DKind
t) = DForallTelescope -> Map Name DKind -> Map Name DKind
go_tele DForallTelescope
tele (DKind -> Map Name DKind
go_ty DKind
t)
go_ty (DConstrainedT [DKind]
ctxt DKind
t) = (DKind -> Map Name DKind) -> [DKind] -> Map Name DKind
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DKind -> Map Name DKind
go_ty [DKind]
ctxt Map Name DKind -> Map Name DKind -> Map Name DKind
forall a. Monoid a => a -> a -> a
`mappend` DKind -> Map Name DKind
go_ty DKind
t
go_ty (DAppT DKind
t1 DKind
t2) = DKind -> Map Name DKind
go_ty DKind
t1 Map Name DKind -> Map Name DKind -> Map Name DKind
forall a. Monoid a => a -> a -> a
`mappend` DKind -> Map Name DKind
go_ty DKind
t2
go_ty (DAppKindT DKind
t DKind
k) = DKind -> Map Name DKind
go_ty DKind
t Map Name DKind -> Map Name DKind -> Map Name DKind
forall a. Monoid a => a -> a -> a
`mappend` DKind -> Map Name DKind
go_ty DKind
k
go_ty (DSigT DKind
t DKind
k) =
let kSigs :: Map Name DKind
kSigs = DKind -> Map Name DKind
go_ty DKind
k
in case DKind
t of
DVarT Name
n -> Name -> DKind -> Map Name DKind -> Map Name DKind
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
n DKind
k Map Name DKind
kSigs
DKind
_ -> DKind -> Map Name DKind
go_ty DKind
t Map Name DKind -> Map Name DKind -> Map Name DKind
forall a. Monoid a => a -> a -> a
`mappend` Map Name DKind
kSigs
go_ty (DVarT {}) = Map Name DKind
forall a. Monoid a => a
mempty
go_ty (DConT {}) = Map Name DKind
forall a. Monoid a => a
mempty
go_ty DKind
DArrowT = Map Name DKind
forall a. Monoid a => a
mempty
go_ty (DLitT {}) = Map Name DKind
forall a. Monoid a => a
mempty
go_ty DKind
DWildCardT = Map Name DKind
forall a. Monoid a => a
mempty
go_tele :: DForallTelescope -> Map Name DKind -> Map Name DKind
go_tele :: DForallTelescope -> Map Name DKind -> Map Name DKind
go_tele (DForallVis [DTyVarBndrUnit]
tvbs) = [DTyVarBndrUnit] -> Map Name DKind -> Map Name DKind
forall flag. [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind
go_tvbs [DTyVarBndrUnit]
tvbs
go_tele (DForallInvis [DTyVarBndrSpec]
tvbs) = [DTyVarBndrSpec] -> Map Name DKind -> Map Name DKind
forall flag. [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind
go_tvbs [DTyVarBndrSpec]
tvbs
go_tvbs :: [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind
go_tvbs :: forall flag. [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind
go_tvbs [DTyVarBndr flag]
tvbs Map Name DKind
m = (DTyVarBndr flag -> Map Name DKind -> Map Name DKind)
-> Map Name DKind -> [DTyVarBndr flag] -> Map Name DKind
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DTyVarBndr flag -> Map Name DKind -> Map Name DKind
forall flag. DTyVarBndr flag -> Map Name DKind -> Map Name DKind
go_tvb Map Name DKind
m [DTyVarBndr flag]
tvbs
go_tvb :: DTyVarBndr flag -> Map Name DKind -> Map Name DKind
go_tvb :: forall flag. DTyVarBndr flag -> Map Name DKind -> Map Name DKind
go_tvb (DPlainTV Name
n flag
_) Map Name DKind
m = Name -> Map Name DKind -> Map Name DKind
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Name
n Map Name DKind
m
go_tvb (DKindedTV Name
n flag
_ DKind
k) Map Name DKind
m = Name -> Map Name DKind -> Map Name DKind
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Name
n Map Name DKind
m Map Name DKind -> Map Name DKind -> Map Name DKind
forall a. Monoid a => a -> a -> a
`mappend` DKind -> Map Name DKind
go_ty DKind
k
scopedSort :: [Name] -> [Name]
scopedSort :: [Name] -> [Name]
scopedSort = [Name] -> [Set Name] -> [Name] -> [Name]
go [] []
go :: [Name]
-> [Set Name]
-> [Name]
-> [Name]
go :: [Name] -> [Set Name] -> [Name] -> [Name]
go [Name]
acc [Set Name]
_fv_list [] = [Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
acc
go [Name]
acc [Set Name]
fv_list (Name
tv:[Name]
tvs)
= [Name] -> [Set Name] -> [Name] -> [Name]
go [Name]
acc' [Set Name]
fv_list' [Name]
tvs
where
([Name]
acc', [Set Name]
fv_list') = Name -> [Name] -> [Set Name] -> ([Name], [Set Name])
insert Name
tv [Name]
acc [Set Name]
fv_list
insert :: Name
-> [Name]
-> [Set Name]
-> ([Name], [Set Name])
insert :: Name -> [Name] -> [Set Name] -> ([Name], [Set Name])
insert Name
tv [] [] = ([Name
tv], [Name -> Set Name
kindFVSet Name
tv])
insert Name
tv (Name
a:[Name]
as) (Set Name
fvs:[Set Name]
fvss)
| Name
tv Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Name
fvs
, ([Name]
as', [Set Name]
fvss') <- Name -> [Name] -> [Set Name] -> ([Name], [Set Name])
insert Name
tv [Name]
as [Set Name]
fvss
= (Name
aName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
as', Set Name
fvs Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set Name
fv_tv Set Name -> [Set Name] -> [Set Name]
forall a. a -> [a] -> [a]
: [Set Name]
fvss')
| Bool
otherwise
= (Name
tvName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Name
aName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
as, Set Name
fvs Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set Name
fv_tv Set Name -> [Set Name] -> [Set Name]
forall a. a -> [a] -> [a]
: Set Name
fvs Set Name -> [Set Name] -> [Set Name]
forall a. a -> [a] -> [a]
: [Set Name]
fvss)
where
fv_tv :: Set Name
fv_tv = Name -> Set Name
kindFVSet Name
tv
insert Name
_ [Name]
_ [Set Name]
_ = String -> ([Name], [Set Name])
forall a. HasCallStack => String -> a
error String
"scopedSort"
kindFVSet :: Name -> Set Name
kindFVSet Name
n =
Set Name -> (DKind -> Set Name) -> Maybe DKind -> Set Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Name
forall a. Set a
S.empty (OSet Name -> Set Name
forall a. OSet a -> Set a
OS.toSet (OSet Name -> Set Name)
-> (DKind -> OSet Name) -> DKind -> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DKind -> OSet Name
fvDType)
(Name -> Map Name DKind -> Maybe DKind
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n Map Name DKind
varKindSigs)
ascribeWithKind :: Name -> DTyVarBndrUnit
ascribeWithKind Name
n =
DTyVarBndrUnit
-> (DKind -> DTyVarBndrUnit) -> Maybe DKind -> DTyVarBndrUnit
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> () -> DTyVarBndrUnit
forall flag. Name -> flag -> DTyVarBndr flag
DPlainTV Name
n ()) (Name -> () -> DKind -> DTyVarBndrUnit
forall flag. Name -> flag -> DKind -> DTyVarBndr flag
DKindedTV Name
n ()) (Name -> Map Name DKind -> Maybe DKind
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n Map Name DKind
varKindSigs)
in (Name -> DTyVarBndrUnit) -> [Name] -> [DTyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DTyVarBndrUnit
ascribeWithKind ([Name] -> [DTyVarBndrUnit]) -> [Name] -> [DTyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$
[Name] -> [Name]
scopedSort [Name]
freeVars
dtvbName :: DTyVarBndr flag -> Name
dtvbName :: forall flag. DTyVarBndr flag -> Name
dtvbName (DPlainTV Name
n flag
_) = Name
n
dtvbName (DKindedTV Name
n flag
_ DKind
_) = Name
n
mk_qual_do_name :: Maybe ModName -> Name -> Name
mk_qual_do_name :: Maybe ModName -> Name -> Name
mk_qual_do_name Maybe ModName
mb_mod Name
orig_name = case Maybe ModName
mb_mod of
Maybe ModName
Nothing -> Name
orig_name
Just ModName
mod_ -> OccName -> NameFlavour -> Name
Name (String -> OccName
OccName (Name -> String
nameBase Name
orig_name)) (ModName -> NameFlavour
NameQ ModName
mod_)
ravelDType :: DFunArgs -> DType -> DType
ravelDType :: DFunArgs -> DKind -> DKind
ravelDType DFunArgs
DFANil DKind
res = DKind
res
ravelDType (DFAForalls DForallTelescope
tele DFunArgs
args) DKind
res = DForallTelescope -> DKind -> DKind
DForallT DForallTelescope
tele (DFunArgs -> DKind -> DKind
ravelDType DFunArgs
args DKind
res)
ravelDType (DFACxt [DKind]
cxt DFunArgs
args) DKind
res = [DKind] -> DKind -> DKind
DConstrainedT [DKind]
cxt (DFunArgs -> DKind -> DKind
ravelDType DFunArgs
args DKind
res)
ravelDType (DFAAnon DKind
t DFunArgs
args) DKind
res = DKind -> DKind -> DKind
DAppT (DKind -> DKind -> DKind
DAppT DKind
DArrowT DKind
t) (DFunArgs -> DKind -> DKind
ravelDType DFunArgs
args DKind
res)
unravelDType :: DType -> (DFunArgs, DType)
unravelDType :: DKind -> (DFunArgs, DKind)
unravelDType (DForallT DForallTelescope
tele DKind
ty) =
let (DFunArgs
args, DKind
res) = DKind -> (DFunArgs, DKind)
unravelDType DKind
ty in
(DForallTelescope -> DFunArgs -> DFunArgs
DFAForalls DForallTelescope
tele DFunArgs
args, DKind
res)
unravelDType (DConstrainedT [DKind]
cxt DKind
ty) =
let (DFunArgs
args, DKind
res) = DKind -> (DFunArgs, DKind)
unravelDType DKind
ty in
([DKind] -> DFunArgs -> DFunArgs
DFACxt [DKind]
cxt DFunArgs
args, DKind
res)
unravelDType (DAppT (DAppT DKind
DArrowT DKind
t1) DKind
t2) =
let (DFunArgs
args, DKind
res) = DKind -> (DFunArgs, DKind)
unravelDType DKind
t2 in
(DKind -> DFunArgs -> DFunArgs
DFAAnon DKind
t1 DFunArgs
args, DKind
res)
unravelDType DKind
t = (DFunArgs
DFANil, DKind
t)
data DFunArgs
= DFANil
| DFAForalls DForallTelescope DFunArgs
| DFACxt DCxt DFunArgs
| DFAAnon DType DFunArgs
deriving (DFunArgs -> DFunArgs -> Bool
(DFunArgs -> DFunArgs -> Bool)
-> (DFunArgs -> DFunArgs -> Bool) -> Eq DFunArgs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DFunArgs -> DFunArgs -> Bool
== :: DFunArgs -> DFunArgs -> Bool
$c/= :: DFunArgs -> DFunArgs -> Bool
/= :: DFunArgs -> DFunArgs -> Bool
Eq, Int -> DFunArgs -> String -> String
[DFunArgs] -> String -> String
DFunArgs -> String
(Int -> DFunArgs -> String -> String)
-> (DFunArgs -> String)
-> ([DFunArgs] -> String -> String)
-> Show DFunArgs
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DFunArgs -> String -> String
showsPrec :: Int -> DFunArgs -> String -> String
$cshow :: DFunArgs -> String
show :: DFunArgs -> String
$cshowList :: [DFunArgs] -> String -> String
showList :: [DFunArgs] -> String -> String
Show, Typeable DFunArgs
Typeable DFunArgs =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DFunArgs -> c DFunArgs)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DFunArgs)
-> (DFunArgs -> Constr)
-> (DFunArgs -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DFunArgs))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DFunArgs))
-> ((forall b. Data b => b -> b) -> DFunArgs -> DFunArgs)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DFunArgs -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DFunArgs -> r)
-> (forall u. (forall d. Data d => d -> u) -> DFunArgs -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> DFunArgs -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs)
-> Data DFunArgs
DFunArgs -> Constr
DFunArgs -> DataType
(forall b. Data b => b -> b) -> DFunArgs -> DFunArgs
forall a.
Typeable a =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> DFunArgs -> u
forall u. (forall d. Data d => d -> u) -> DFunArgs -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DFunArgs -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DFunArgs -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DFunArgs
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DFunArgs -> c DFunArgs
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DFunArgs)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DFunArgs)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DFunArgs -> c DFunArgs
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DFunArgs -> c DFunArgs
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DFunArgs
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DFunArgs
$ctoConstr :: DFunArgs -> Constr
toConstr :: DFunArgs -> Constr
$cdataTypeOf :: DFunArgs -> DataType
dataTypeOf :: DFunArgs -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DFunArgs)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DFunArgs)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DFunArgs)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DFunArgs)
$cgmapT :: (forall b. Data b => b -> b) -> DFunArgs -> DFunArgs
gmapT :: (forall b. Data b => b -> b) -> DFunArgs -> DFunArgs
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DFunArgs -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DFunArgs -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DFunArgs -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DFunArgs -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DFunArgs -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> DFunArgs -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DFunArgs -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DFunArgs -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
Data, (forall x. DFunArgs -> Rep DFunArgs x)
-> (forall x. Rep DFunArgs x -> DFunArgs) -> Generic DFunArgs
forall x. Rep DFunArgs x -> DFunArgs
forall x. DFunArgs -> Rep DFunArgs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DFunArgs -> Rep DFunArgs x
from :: forall x. DFunArgs -> Rep DFunArgs x
$cto :: forall x. Rep DFunArgs x -> DFunArgs
to :: forall x. Rep DFunArgs x -> DFunArgs
Generic)
data DVisFunArg
= DVisFADep DTyVarBndrUnit
| DVisFAAnon DType
deriving (DVisFunArg -> DVisFunArg -> Bool
(DVisFunArg -> DVisFunArg -> Bool)
-> (DVisFunArg -> DVisFunArg -> Bool) -> Eq DVisFunArg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DVisFunArg -> DVisFunArg -> Bool
== :: DVisFunArg -> DVisFunArg -> Bool
$c/= :: DVisFunArg -> DVisFunArg -> Bool
/= :: DVisFunArg -> DVisFunArg -> Bool
Eq, Int -> DVisFunArg -> String -> String
[DVisFunArg] -> String -> String
DVisFunArg -> String
(Int -> DVisFunArg -> String -> String)
-> (DVisFunArg -> String)
-> ([DVisFunArg] -> String -> String)
-> Show DVisFunArg
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DVisFunArg -> String -> String
showsPrec :: Int -> DVisFunArg -> String -> String
$cshow :: DVisFunArg -> String
show :: DVisFunArg -> String
$cshowList :: [DVisFunArg] -> String -> String
showList :: [DVisFunArg] -> String -> String
Show, Typeable DVisFunArg
Typeable DVisFunArg =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DVisFunArg -> c DVisFunArg)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DVisFunArg)
-> (DVisFunArg -> Constr)
-> (DVisFunArg -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DVisFunArg))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DVisFunArg))
-> ((forall b. Data b => b -> b) -> DVisFunArg -> DVisFunArg)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r)
-> (forall u. (forall d. Data d => d -> u) -> DVisFunArg -> [u])
-> (forall u.
Int -> (forall d. Data d => d -> u) -> DVisFunArg -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg)
-> Data DVisFunArg
DVisFunArg -> Constr
DVisFunArg -> DataType
(forall b. Data b => b -> b) -> DVisFunArg -> DVisFunArg
forall a.
Typeable a =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> DVisFunArg -> u
forall u. (forall d. Data d => d -> u) -> DVisFunArg -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DVisFunArg
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DVisFunArg -> c DVisFunArg
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DVisFunArg)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DVisFunArg)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DVisFunArg -> c DVisFunArg
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DVisFunArg -> c DVisFunArg
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DVisFunArg
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DVisFunArg
$ctoConstr :: DVisFunArg -> Constr
toConstr :: DVisFunArg -> Constr
$cdataTypeOf :: DVisFunArg -> DataType
dataTypeOf :: DVisFunArg -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DVisFunArg)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DVisFunArg)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DVisFunArg)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DVisFunArg)
$cgmapT :: (forall b. Data b => b -> b) -> DVisFunArg -> DVisFunArg
gmapT :: (forall b. Data b => b -> b) -> DVisFunArg -> DVisFunArg
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DVisFunArg -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> DVisFunArg -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DVisFunArg -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DVisFunArg -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
Data, (forall x. DVisFunArg -> Rep DVisFunArg x)
-> (forall x. Rep DVisFunArg x -> DVisFunArg) -> Generic DVisFunArg
forall x. Rep DVisFunArg x -> DVisFunArg
forall x. DVisFunArg -> Rep DVisFunArg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DVisFunArg -> Rep DVisFunArg x
from :: forall x. DVisFunArg -> Rep DVisFunArg x
$cto :: forall x. Rep DVisFunArg x -> DVisFunArg
to :: forall x. Rep DVisFunArg x -> DVisFunArg
Generic)
filterDVisFunArgs :: DFunArgs -> [DVisFunArg]
filterDVisFunArgs :: DFunArgs -> [DVisFunArg]
filterDVisFunArgs DFunArgs
DFANil = []
filterDVisFunArgs (DFAForalls DForallTelescope
tele DFunArgs
args) =
case DForallTelescope
tele of
DForallVis [DTyVarBndrUnit]
tvbs -> (DTyVarBndrUnit -> DVisFunArg) -> [DTyVarBndrUnit] -> [DVisFunArg]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrUnit -> DVisFunArg
DVisFADep [DTyVarBndrUnit]
tvbs [DVisFunArg] -> [DVisFunArg] -> [DVisFunArg]
forall a. [a] -> [a] -> [a]
++ [DVisFunArg]
args'
DForallInvis [DTyVarBndrSpec]
_ -> [DVisFunArg]
args'
where
args' :: [DVisFunArg]
args' = DFunArgs -> [DVisFunArg]
filterDVisFunArgs DFunArgs
args
filterDVisFunArgs (DFACxt [DKind]
_ DFunArgs
args) =
DFunArgs -> [DVisFunArg]
filterDVisFunArgs DFunArgs
args
filterDVisFunArgs (DFAAnon DKind
t DFunArgs
args) =
DKind -> DVisFunArg
DVisFAAnon DKind
tDVisFunArg -> [DVisFunArg] -> [DVisFunArg]
forall a. a -> [a] -> [a]
:DFunArgs -> [DVisFunArg]
filterDVisFunArgs DFunArgs
args
unfoldDType :: DType -> (DType, [DTypeArg])
unfoldDType :: DKind -> (DKind, [DTypeArg])
unfoldDType = [DTypeArg] -> DKind -> (DKind, [DTypeArg])
go []
where
go :: [DTypeArg] -> DType -> (DType, [DTypeArg])
go :: [DTypeArg] -> DKind -> (DKind, [DTypeArg])
go [DTypeArg]
acc (DForallT DForallTelescope
_ DKind
ty) = [DTypeArg] -> DKind -> (DKind, [DTypeArg])
go [DTypeArg]
acc DKind
ty
go [DTypeArg]
acc (DAppT DKind
ty1 DKind
ty2) = [DTypeArg] -> DKind -> (DKind, [DTypeArg])
go (DKind -> DTypeArg
DTANormal DKind
ty2DTypeArg -> [DTypeArg] -> [DTypeArg]
forall a. a -> [a] -> [a]
:[DTypeArg]
acc) DKind
ty1
go [DTypeArg]
acc (DAppKindT DKind
ty DKind
ki) = [DTypeArg] -> DKind -> (DKind, [DTypeArg])
go (DKind -> DTypeArg
DTyArg DKind
kiDTypeArg -> [DTypeArg] -> [DTypeArg]
forall a. a -> [a] -> [a]
:[DTypeArg]
acc) DKind
ty
go [DTypeArg]
acc (DSigT DKind
ty DKind
_) = [DTypeArg] -> DKind -> (DKind, [DTypeArg])
go [DTypeArg]
acc DKind
ty
go [DTypeArg]
acc DKind
ty = (DKind
ty, [DTypeArg]
acc)
extractTvbKind :: DTyVarBndr flag -> Maybe DKind
(DPlainTV Name
_ flag
_) = Maybe DKind
forall a. Maybe a
Nothing
extractTvbKind (DKindedTV Name
_ flag
_ DKind
k) = DKind -> Maybe DKind
forall a. a -> Maybe a
Just DKind
k
changeDTVFlags :: newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags :: forall newFlag oldFlag.
newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags newFlag
new_flag = (DTyVarBndr oldFlag -> DTyVarBndr newFlag)
-> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
forall a b. (a -> b) -> [a] -> [b]
map (newFlag
new_flag newFlag -> DTyVarBndr oldFlag -> DTyVarBndr newFlag
forall a b. a -> DTyVarBndr b -> DTyVarBndr a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$)
unusedArgument :: a
unusedArgument :: forall a. a
unusedArgument = String -> a
forall a. HasCallStack => String -> a
error String
"Unused"