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