{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies,
TypeSynonymInstances, FlexibleInstances, LambdaCase,
ScopedTypeVariables, PatternSynonyms #-}
module Language.Haskell.TH.Desugar (
DExp(..), DLetDec(..), DPat(..),
DType(..), DForallTelescope(..), DKind, DCxt, DPred,
DTyVarBndr(..), DTyVarBndrSpec, DTyVarBndrUnit, Specificity(..),
DTyVarBndrVis,
#if __GLASGOW_HASKELL__ >= 907
BndrVis(..),
#else
BndrVis,
pattern BndrReq,
pattern BndrInvis,
#endif
DMatch(..), DClause(..), DDec(..),
DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType,
Overlap(..), PatSynArgs(..), DataFlavor(..),
DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..),
DCon(..), DConFields(..), DDeclaredInfix, DBangType, DVarBangType,
Bang(..), SourceUnpackedness(..), SourceStrictness(..),
DForeign(..),
DPragma(..), DRuleBndr(..), DTySynEqn(..), DInfo(..), DInstanceDec,
Role(..), AnnTarget(..),
Desugar(..),
dsExp, dsDecs, dsType, dsInfo,
dsPatOverExp, dsPatsOverExp, dsPatX,
dsLetDecs, dsTvb, dsTvbSpec, dsTvbUnit, dsTvbVis, dsCxt,
dsCon, dsForeign, dsPragma, dsRuleBndr,
PatM, dsPred, dsPat, dsDec, dsDataDec, dsDataInstDec,
DerivingClause, dsDerivClause, dsLetDec,
dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses,
dsBangType, dsVarBangType,
dsTypeFamilyHead, dsFamilyResultSig,
#if __GLASGOW_HASKELL__ >= 801
dsPatSynDir,
#endif
dsTypeArg,
module Language.Haskell.TH.Desugar.Sweeten,
expand, expandType,
reifyWithWarning,
withLocalDeclarations, dsReify, dsReifyType,
reifyWithLocals_maybe, reifyWithLocals, reifyFixityWithLocals,
reifyTypeWithLocals_maybe, reifyTypeWithLocals,
lookupValueNameWithLocals, lookupTypeNameWithLocals,
mkDataNameWithLocals, mkTypeNameWithLocals,
reifyNameSpace,
DsMonad(..), DsM,
scExp, scLetDec,
module Language.Haskell.TH.Desugar.Subst,
module Language.Haskell.TH.Desugar.FV,
applyDExp,
dPatToDExp, removeWilds,
getDataD, dataConNameToDataName, dataConNameToCon,
nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors,
mkTypeName, mkDataName, newUniqueName,
mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE, mkDLamEFromDPats,
tupleNameDegree_maybe,
unboxedSumNameDegree_maybe, unboxedTupleNameDegree_maybe,
isTypeKindName, typeKindName, bindIP,
mkExtraDKindBinders, dTyVarBndrToDType, changeDTVFlags,
toposortTyVarsOf, toposortKindVarsOfTvbs,
FunArgs(..), ForallTelescope(..), VisFunArg(..),
filterVisFunArgs, ravelType, unravelType,
DFunArgs(..), DVisFunArg(..),
filterDVisFunArgs, ravelDType, unravelDType,
TypeArg(..), applyType, filterTANormals,
tyVarBndrVisToTypeArg, tyVarBndrVisToTypeArgWithSig,
unfoldType,
DTypeArg(..), applyDType, filterDTANormals,
dTyVarBndrVisToDTypeArg, dTyVarBndrVisToDTypeArgWithSig,
unfoldDType,
extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat
) where
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH.Desugar.AST
import Language.Haskell.TH.Desugar.Core
import Language.Haskell.TH.Desugar.Expand
import Language.Haskell.TH.Desugar.FV
import Language.Haskell.TH.Desugar.Match
import Language.Haskell.TH.Desugar.Reify
import Language.Haskell.TH.Desugar.Subst
import Language.Haskell.TH.Desugar.Sweeten
import Language.Haskell.TH.Desugar.Util
import Language.Haskell.TH.Syntax
import Control.Monad
import qualified Data.Foldable as F
import Data.Function
import qualified Data.Map as M
import qualified Data.Set as S
import Prelude hiding ( exp )
class Desugar th ds | ds -> th where
desugar :: DsMonad q => th -> q ds
sweeten :: ds -> th
instance Desugar Exp DExp where
desugar :: forall (q :: * -> *). DsMonad q => Exp -> q DExp
desugar = forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp
sweeten :: DExp -> Exp
sweeten = DExp -> Exp
expToTH
instance Desugar Type DType where
desugar :: forall (q :: * -> *). DsMonad q => Type -> q DType
desugar = forall (q :: * -> *). DsMonad q => Type -> q DType
dsType
sweeten :: DType -> Type
sweeten = DType -> Type
typeToTH
instance Desugar Cxt DCxt where
desugar :: forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
desugar = forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
dsCxt
sweeten :: DCxt -> Cxt
sweeten = DCxt -> Cxt
cxtToTH
#if __GLASGOW_HASKELL__ >= 900
instance Desugar (TyVarBndr flag) (DTyVarBndr flag) where
desugar :: forall (q :: * -> *).
DsMonad q =>
TyVarBndr flag -> q (DTyVarBndr flag)
desugar = forall (q :: * -> *) flag.
DsMonad q =>
TyVarBndr_ flag -> q (DTyVarBndr flag)
dsTvb
sweeten :: DTyVarBndr flag -> TyVarBndr flag
sweeten = forall flag. DTyVarBndr flag -> TyVarBndr flag
tvbToTH
#else
instance Desugar TyVarBndrSpec DTyVarBndrSpec where
desugar = dsTvbSpec
sweeten = tvbToTH
instance Desugar TyVarBndrUnit DTyVarBndrUnit where
desugar = dsTvbUnit
sweeten = tvbToTH
#endif
instance Desugar [Dec] [DDec] where
desugar :: forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
desugar = forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs
sweeten :: [DDec] -> [Dec]
sweeten = [DDec] -> [Dec]
decsToTH
instance Desugar TypeArg DTypeArg where
desugar :: forall (q :: * -> *). DsMonad q => TypeArg -> q DTypeArg
desugar = forall (q :: * -> *). DsMonad q => TypeArg -> q DTypeArg
dsTypeArg
sweeten :: DTypeArg -> TypeArg
sweeten = DTypeArg -> TypeArg
typeArgToTH
flattenDValD :: Quasi q => DLetDec -> q [DLetDec]
flattenDValD :: forall (q :: * -> *). Quasi q => DLetDec -> q [DLetDec]
flattenDValD dec :: DLetDec
dec@(DValD (DVarP Name
_) DExp
_) = forall (m :: * -> *) a. Monad m => a -> m a
return [DLetDec
dec]
flattenDValD (DValD DPat
pat DExp
exp) = do
Name
x <- forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"x"
let top_val_d :: DLetDec
top_val_d = DPat -> DExp -> DLetDec
DValD (Name -> DPat
DVarP Name
x) DExp
exp
bound_names :: [Name]
bound_names = forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList forall a b. (a -> b) -> a -> b
$ DPat -> OSet Name
extractBoundNamesDPat DPat
pat
[DLetDec]
other_val_ds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {m :: * -> *}. Quasi m => Name -> Name -> m DLetDec
mk_val_d Name
x) [Name]
bound_names
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DLetDec
top_val_d forall a. a -> [a] -> [a]
: [DLetDec]
other_val_ds
where
mk_val_d :: Name -> Name -> m DLetDec
mk_val_d Name
x Name
name = do
Name
y <- forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"y"
let pat' :: DPat
pat' = Name -> Name -> DPat -> DPat
wildify Name
name Name
y DPat
pat
match :: DMatch
match = DPat -> DExp -> DMatch
DMatch DPat
pat' (Name -> DExp
DVarE Name
y)
cas :: DExp
cas = DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
x) [DMatch
match]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DPat -> DExp -> DLetDec
DValD (Name -> DPat
DVarP Name
name) DExp
cas
wildify :: Name -> Name -> DPat -> DPat
wildify Name
name Name
y DPat
p =
case DPat
p of
DLitP Lit
lit -> Lit -> DPat
DLitP Lit
lit
DVarP Name
n
| Name
n forall a. Eq a => a -> a -> Bool
== Name
name -> Name -> DPat
DVarP Name
y
| Bool
otherwise -> DPat
DWildP
DConP Name
con DCxt
ts [DPat]
ps -> Name -> DCxt -> [DPat] -> DPat
DConP Name
con DCxt
ts (forall a b. (a -> b) -> [a] -> [b]
map (Name -> Name -> DPat -> DPat
wildify Name
name Name
y) [DPat]
ps)
DTildeP DPat
pa -> DPat -> DPat
DTildeP (Name -> Name -> DPat -> DPat
wildify Name
name Name
y DPat
pa)
DBangP DPat
pa -> DPat -> DPat
DBangP (Name -> Name -> DPat -> DPat
wildify Name
name Name
y DPat
pa)
DSigP DPat
pa DType
ty -> DPat -> DType -> DPat
DSigP (Name -> Name -> DPat -> DPat
wildify Name
name Name
y DPat
pa) DType
ty
DPat
DWildP -> DPat
DWildP
flattenDValD DLetDec
other_dec = forall (m :: * -> *) a. Monad m => a -> m a
return [DLetDec
other_dec]
getRecordSelectors :: DsMonad q => [DCon] -> q [DLetDec]
getRecordSelectors :: forall (q :: * -> *). DsMonad q => [DCon] -> q [DLetDec]
getRecordSelectors [DCon]
cons = [DLetDec] -> [DLetDec]
merge_let_decs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM forall {m :: * -> *}. Quasi m => DCon -> m [DLetDec]
get_record_sels [DCon]
cons
where
get_record_sels :: DCon -> m [DLetDec]
get_record_sels (DCon [DTyVarBndrSpec]
con_tvbs DCxt
_ Name
con_name DConFields
con_fields DType
con_ret_ty) =
case DConFields
con_fields of
DRecC [DVarBangType]
fields -> forall {m :: * -> *} {b}.
Quasi m =>
[(Name, b, DType)] -> m [DLetDec]
go [DVarBangType]
fields
DNormalC{} -> forall (m :: * -> *) a. Monad m => a -> m a
return []
where
go :: [(Name, b, DType)] -> m [DLetDec]
go [(Name, b, DType)]
fields = do
Name
varName <- forall (q :: * -> *). Quasi q => String -> q Name
qNewName String
"field"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ Name -> DType -> DLetDec
DSigD Name
name forall a b. (a -> b) -> a -> b
$ DForallTelescope -> DType -> DType
DForallT ([DTyVarBndrSpec] -> DForallTelescope
DForallInvis [DTyVarBndrSpec]
con_tvbs)
forall a b. (a -> b) -> a -> b
$ DType
DArrowT DType -> DType -> DType
`DAppT` DType
con_ret_ty DType -> DType -> DType
`DAppT` DType
field_ty
, Name -> [DClause] -> DLetDec
DFunD Name
name [[DPat] -> DExp -> DClause
DClause [Name -> DCxt -> [DPat] -> DPat
DConP Name
con_name []
(Int -> Int -> Name -> [DPat]
mk_field_pats Int
n (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, b, DType)]
fields) Name
varName)]
(Name -> DExp
DVarE Name
varName)] ]
| ((Name
name, b
_strict, DType
field_ty), Int
n) <- forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, b, DType)]
fields [Int
0..]
]
mk_field_pats :: Int -> Int -> Name -> [DPat]
mk_field_pats :: Int -> Int -> Name -> [DPat]
mk_field_pats Int
0 Int
total Name
name = Name -> DPat
DVarP Name
name forall a. a -> [a] -> [a]
: (forall a. Int -> a -> [a]
replicate (Int
totalforall a. Num a => a -> a -> a
-Int
1) DPat
DWildP)
mk_field_pats Int
n Int
total Name
name = DPat
DWildP forall a. a -> [a] -> [a]
: Int -> Int -> Name -> [DPat]
mk_field_pats (Int
nforall a. Num a => a -> a -> a
-Int
1) (Int
totalforall a. Num a => a -> a -> a
-Int
1) Name
name
merge_let_decs :: [DLetDec] -> [DLetDec]
merge_let_decs :: [DLetDec] -> [DLetDec]
merge_let_decs [DLetDec]
decs =
let (Map Name [DClause]
name_clause_map, [DLetDec]
decs') = Map Name [DClause]
-> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
gather_decs forall k a. Map k a
M.empty forall a. Set a
S.empty [DLetDec]
decs
in Map Name [DClause] -> [DLetDec] -> [DLetDec]
augment_clauses Map Name [DClause]
name_clause_map [DLetDec]
decs'
where
gather_decs :: M.Map Name [DClause] -> S.Set Name -> [DLetDec]
-> (M.Map Name [DClause], [DLetDec])
gather_decs :: Map Name [DClause]
-> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
gather_decs Map Name [DClause]
name_clause_map Set Name
_ [] = (Map Name [DClause]
name_clause_map, [])
gather_decs Map Name [DClause]
name_clause_map Set Name
type_sig_names (DLetDec
x:[DLetDec]
xs)
| DFunD Name
n [DClause]
clauses <- DLetDec
x
= let name_clause_map' :: Map Name [DClause]
name_clause_map' = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (\[DClause]
new [DClause]
old -> [DClause]
old forall a. [a] -> [a] -> [a]
++ [DClause]
new)
Name
n [DClause]
clauses Map Name [DClause]
name_clause_map
in if Name
n forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map Name [DClause]
name_clause_map
then Map Name [DClause]
-> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
gather_decs Map Name [DClause]
name_clause_map' Set Name
type_sig_names [DLetDec]
xs
else let (Map Name [DClause]
map', [DLetDec]
decs') = Map Name [DClause]
-> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
gather_decs Map Name [DClause]
name_clause_map'
Set Name
type_sig_names [DLetDec]
xs
in (Map Name [DClause]
map', DLetDec
xforall a. a -> [a] -> [a]
:[DLetDec]
decs')
| DSigD Name
n DType
_ <- DLetDec
x
= if Name
n forall a. Ord a => a -> Set a -> Bool
`S.member` Set Name
type_sig_names
then Map Name [DClause]
-> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
gather_decs Map Name [DClause]
name_clause_map Set Name
type_sig_names [DLetDec]
xs
else let (Map Name [DClause]
map', [DLetDec]
decs') = Map Name [DClause]
-> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
gather_decs Map Name [DClause]
name_clause_map
(Name
n forall a. Ord a => a -> Set a -> Set a
`S.insert` Set Name
type_sig_names) [DLetDec]
xs
in (Map Name [DClause]
map', DLetDec
xforall a. a -> [a] -> [a]
:[DLetDec]
decs')
| Bool
otherwise =
let (Map Name [DClause]
map', [DLetDec]
decs') = Map Name [DClause]
-> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
gather_decs Map Name [DClause]
name_clause_map Set Name
type_sig_names [DLetDec]
xs
in (Map Name [DClause]
map', DLetDec
xforall a. a -> [a] -> [a]
:[DLetDec]
decs')
augment_clauses :: M.Map Name [DClause] -> [DLetDec] -> [DLetDec]
augment_clauses :: Map Name [DClause] -> [DLetDec] -> [DLetDec]
augment_clauses Map Name [DClause]
_ [] = []
augment_clauses Map Name [DClause]
name_clause_map (DLetDec
x:[DLetDec]
xs)
| DFunD Name
n [DClause]
_ <- DLetDec
x, Just [DClause]
merged_clauses <- Name
n forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Name [DClause]
name_clause_map
= Name -> [DClause] -> DLetDec
DFunD Name
n [DClause]
merged_clausesforall a. a -> [a] -> [a]
:Map Name [DClause] -> [DLetDec] -> [DLetDec]
augment_clauses Map Name [DClause]
name_clause_map [DLetDec]
xs
| Bool
otherwise = DLetDec
xforall a. a -> [a] -> [a]
:Map Name [DClause] -> [DLetDec] -> [DLetDec]
augment_clauses Map Name [DClause]
name_clause_map [DLetDec]
xs
mkExtraDKindBinders :: forall q. DsMonad q => DKind -> q [DTyVarBndrVis]
DType
k = do
DType
k' <- forall (q :: * -> *). DsMonad q => DType -> q DType
expandType DType
k
let (DFunArgs
fun_args, DType
_) = DType -> (DFunArgs, DType)
unravelDType DType
k'
vis_fun_args :: [DVisFunArg]
vis_fun_args = DFunArgs -> [DVisFunArg]
filterDVisFunArgs DFunArgs
fun_args
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DVisFunArg -> q DTyVarBndrVis
mk_tvb [DVisFunArg]
vis_fun_args
where
mk_tvb :: DVisFunArg -> q (DTyVarBndrVis)
mk_tvb :: DVisFunArg -> q DTyVarBndrVis
mk_tvb (DVisFADep DTyVarBndrVis
tvb) = forall (m :: * -> *) a. Monad m => a -> m a
return (BndrVis
BndrReq forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ DTyVarBndrVis
tvb)
mk_tvb (DVisFAAnon DType
ki) = do
Name
name <- forall (q :: * -> *). Quasi q => String -> q Name
qNewName String
"a"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall flag. Name -> flag -> DType -> DTyVarBndr flag
DKindedTV Name
name BndrVis
BndrReq DType
ki