repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
repTopDs group
- = do { let { bndrs = map unLoc (groupBinders group) } ;
+ = do { let { bndrs = hsGroupBinders group } ;
ss <- mkGenSyms bndrs ;
-- Bind all the names mainly to avoid repeated use of explicit strings.
decls <- addBinds ss (do {
val_ds <- rep_val_binds (hs_valds group) ;
- tycl_ds <- mapM repTyClD (hs_tyclds group) ;
+ tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
inst_ds <- mapM repInstD' (hs_instds group) ;
for_ds <- mapM repForD (hs_fords group) ;
-- more needed
-- Do *not* gensym top-level binders
}
-groupBinders :: HsGroup Name -> [Located Name]
-groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
- hs_instds = inst_decls, hs_fords = foreign_decls })
--- Collect the binders of a Group
- = collectHsValBinders val_decls ++
- [n | d <- tycl_decls ++ assoc_tycl_decls, n <- tyClDeclNames (unLoc d)] ++
- [n | L _ (ForeignImport n _ _) <- foreign_decls]
- where
- assoc_tycl_decls = concat [ats | L _ (InstDecl _ _ _ ats) <- inst_decls]
-
{- Note [Binders and occurrences]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- appear in the resulting data structure
do { cxt1 <- repContext cxt
; inst_ty1 <- repPredTy (HsClassP cls tys)
- ; ss <- mkGenSyms (collectHsBindBinders binds)
+ ; ss <- mkGenSyms (collectHsBindsBinders binds)
; binds1 <- addBinds ss (rep_binds binds)
; ats1 <- repLAssocFamInst ats
; decls1 <- coreList decQTyConName (ats1 ++ binds1)
repSafety :: Safety -> DsM (Core TH.Safety)
repSafety PlayRisky = rep2 unsafeName []
+repSafety PlayInterruptible = rep2 interruptibleName []
repSafety (PlaySafe False) = rep2 safeName []
repSafety (PlaySafe True) = rep2 threadsafeName []
rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma
-> DsM (Core TH.InlineSpecQ)
rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
- | Nothing <- activation1
- = repInlineSpecNoPhase inline1 match1
| Just (flag, phase) <- activation1
- = repInlineSpecPhase inline1 match1 flag phase
- | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec"
- where
+ = repInlineSpecPhase inline1 match1 flag phase
+ | otherwise
+ = repInlineSpecNoPhase inline1 match1
+ where
match1 = coreBool (rep_RuleMatchInfo match)
activation1 = rep_Activation activation
- inline1 = coreBool inline
+ inline1 = case inline of
+ Inline -> coreBool True
+ _other -> coreBool False
+ -- We have no representation for Inlinable
rep_RuleMatchInfo FunLike = False
rep_RuleMatchInfo ConLike = True
--
repTyVarBndrWithKind :: LHsTyVarBndr Name
-> Core TH.Name -> DsM (Core TH.TyVarBndr)
-repTyVarBndrWithKind (L _ (UserTyVar _)) = repPlainTV
-repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) =
- \nm -> repKind ki >>= repKindedTV nm
+repTyVarBndrWithKind (L _ (UserTyVar {})) nm
+ = repPlainTV nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
+ = repKind ki >>= repKindedTV nm
-- represent a type context
--
t1 <- repLTy t
tcon <- repTy (HsTyVar (tyConName parrTyCon))
repTapp tcon t1
-repTy (HsTupleTy _ tys) = do
+repTy (HsTupleTy Boxed tys) = do
tys1 <- repLTys tys
tcon <- repTupleTyCon (length tys)
repTapps tcon tys1
+repTy (HsTupleTy Unboxed tys) = do
+ tys1 <- repLTys tys
+ tcon <- repUnboxedTupleTyCon (length tys)
+ repTapps tcon tys1
repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
`nlHsAppTy` ty2)
repTy (HsParTy t) = repLTy t
t1 <- repLTy t
k1 <- repKind k
repTSig t1 k1
-repTy (HsSpliceTy splice) = repSplice splice
-repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
-repTy ty = notHandled "Exotic form of type" (ppr ty)
+repTy (HsSpliceTy splice _ _) = repSplice splice
+repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
+repTy ty = notHandled "Exotic form of type" (ppr ty)
-- represent a kind
--
= do { let (kis, ki') = splitKindFunTys ki
; kis_rep <- mapM repKind kis
; ki'_rep <- repNonArrowKind ki'
- ; foldlM repArrowK ki'_rep kis_rep
+ ; foldrM repArrowK ki'_rep kis_rep
}
where
repNonArrowKind k | isLiftedTypeKind k = repStarK
repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
; ms2 <- mapM repMatchTup ms
; repCaseE arg (nonEmptyCoreList ms2) }
-repE (HsIf x y z) = do
+repE (HsIf _ x y z) = do
a <- repLE x
b <- repLE y
c <- repLE z
repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
repE e@(ExplicitTuple es boxed)
- | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr e)
| not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
- | otherwise = do { xs <- repLEs [e | Present e <- es]; repTup xs }
+ | isBoxed boxed = do { xs <- repLEs [e | Present e <- es]; repTup xs }
+ | otherwise = do { xs <- repLEs [e | Present e <- es]; repUnboxedTup xs }
repE (RecordCon c _ flds)
= do { x <- lookupLOcc c;
repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
repBinds (HsValBinds decs)
- = do { let { bndrs = map unLoc (collectHsValBinders decs) }
+ = do { let { bndrs = collectHsValBinders decs }
-- No need to worrry about detailed scopes within
-- the binding group, because we are talking Names
-- here, so we can safely treat it as a mutually
; ans <- repVal patcore x empty_decls
; return (srcLocSpan (getSrcLoc v), ans) }
-rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
+rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
-----------------------------------------------------------------------------
-- Since everything in a Bind is mutually recursive we need rename all
repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
repP (ParPat p) = repLP p
repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
-repP p@(TuplePat ps boxed _)
- | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr p)
- | otherwise = do { qs <- repLPs ps; repPtup qs }
+repP (TuplePat ps boxed _)
+ | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
+ | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
repP (ConPatIn dc details)
= do { con_str <- lookupLOcc dc
; case details of
repPinfix p1' con_str p2' }
}
repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
+repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
-- The problem is to do with scoped type variables.
repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
repPtup (MkC ps) = rep2 tupPName [ps]
+repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
+
repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
repPlist (MkC ps) = rep2 listPName [ps]
+repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
+
--------------- Expressions -----------------
repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
repTup (MkC es) = rep2 tupEName [es]
+repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
+
repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
-repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
+repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
-- Note: not Core Int; it's easier to be direct here
repTupleTyCon i = rep2 tupleTName [mkIntExprInt i]
+repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
+-- Note: not Core Int; it's easier to be direct here
+repUnboxedTupleTyCon i = rep2 unboxedTupleTName [mkIntExprInt i]
+
repArrowTyCon :: DsM (Core TH.TypeQ)
repArrowTyCon = rep2 arrowTName []
templateHaskellNames = [
returnQName, bindQName, sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
-
+ liftStringName,
+
-- Lit
charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
- floatPrimLName, doublePrimLName, rationalLName,
+ floatPrimLName, doublePrimLName, rationalLName,
-- Pat
- litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName,
- asPName, wildPName, recPName, listPName, sigPName,
+ litPName, varPName, tupPName, unboxedTupPName,
+ conPName, tildePName, bangPName, infixPName,
+ asPName, wildPName, recPName, listPName, sigPName, viewPName,
-- FieldPat
fieldPatName,
-- Match
clauseName,
-- Exp
varEName, conEName, litEName, appEName, infixEName,
- infixAppName, sectionLName, sectionRName, lamEName, tupEName,
+ infixAppName, sectionLName, sectionRName, lamEName,
+ tupEName, unboxedTupEName,
condEName, letEName, caseEName, doEName, compEName,
fromEName, fromThenEName, fromToEName, fromThenToEName,
listEName, sigEName, recConEName, recUpdEName,
unsafeName,
safeName,
threadsafeName,
+ interruptibleName,
-- InlineSpec
inlineSpecNoPhaseName, inlineSpecPhaseName,
-- FunDep
rationalLName = libFun (fsLit "rationalL") rationalLIdKey
-- data Pat = ...
-litPName, varPName, tupPName, conPName, infixPName, tildePName, bangPName,
- asPName, wildPName, recPName, listPName, sigPName :: Name
+litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName,
+ asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name
litPName = libFun (fsLit "litP") litPIdKey
varPName = libFun (fsLit "varP") varPIdKey
tupPName = libFun (fsLit "tupP") tupPIdKey
+unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey
conPName = libFun (fsLit "conP") conPIdKey
infixPName = libFun (fsLit "infixP") infixPIdKey
tildePName = libFun (fsLit "tildeP") tildePIdKey
recPName = libFun (fsLit "recP") recPIdKey
listPName = libFun (fsLit "listP") listPIdKey
sigPName = libFun (fsLit "sigP") sigPIdKey
+viewPName = libFun (fsLit "viewP") viewPIdKey
-- type FieldPat = ...
fieldPatName :: Name
-- data Exp = ...
varEName, conEName, litEName, appEName, infixEName, infixAppName,
- sectionLName, sectionRName, lamEName, tupEName, condEName,
+ sectionLName, sectionRName, lamEName, tupEName, unboxedTupEName, condEName,
letEName, caseEName, doEName, compEName :: Name
varEName = libFun (fsLit "varE") varEIdKey
conEName = libFun (fsLit "conE") conEIdKey
sectionRName = libFun (fsLit "sectionR") sectionRIdKey
lamEName = libFun (fsLit "lamE") lamEIdKey
tupEName = libFun (fsLit "tupE") tupEIdKey
+unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
condEName = libFun (fsLit "condE") condEIdKey
letEName = libFun (fsLit "letE") letEIdKey
caseEName = libFun (fsLit "caseE") caseEIdKey
varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey
-- data Type = ...
-forallTName, varTName, conTName, tupleTName, arrowTName,
+forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,
listTName, appTName, sigTName :: Name
forallTName = libFun (fsLit "forallT") forallTIdKey
varTName = libFun (fsLit "varT") varTIdKey
conTName = libFun (fsLit "conT") conTIdKey
tupleTName = libFun (fsLit "tupleT") tupleTIdKey
+unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey
arrowTName = libFun (fsLit "arrowT") arrowTIdKey
listTName = libFun (fsLit "listT") listTIdKey
appTName = libFun (fsLit "appT") appTIdKey
stdCallName = libFun (fsLit "stdCall") stdCallIdKey
-- data Safety = ...
-unsafeName, safeName, threadsafeName :: Name
+unsafeName, safeName, threadsafeName, interruptibleName :: Name
unsafeName = libFun (fsLit "unsafe") unsafeIdKey
safeName = libFun (fsLit "safe") safeIdKey
threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
+interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
-- data InlineSpec = ...
inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
liftStringIdKey = mkPreludeMiscIdUnique 218
-- data Pat = ...
-litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
- asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique
+litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
+ asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique
litPIdKey = mkPreludeMiscIdUnique 220
varPIdKey = mkPreludeMiscIdUnique 221
tupPIdKey = mkPreludeMiscIdUnique 222
+unboxedTupPIdKey = mkPreludeMiscIdUnique 362
conPIdKey = mkPreludeMiscIdUnique 223
infixPIdKey = mkPreludeMiscIdUnique 312
tildePIdKey = mkPreludeMiscIdUnique 224
recPIdKey = mkPreludeMiscIdUnique 227
listPIdKey = mkPreludeMiscIdUnique 228
sigPIdKey = mkPreludeMiscIdUnique 229
+viewPIdKey = mkPreludeMiscIdUnique 360
-- type FieldPat = ...
fieldPatIdKey :: Unique
-- data Exp = ...
varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
- sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey,
+ sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, unboxedTupEIdKey,
+ condEIdKey,
letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
sectionRIdKey = mkPreludeMiscIdUnique 247
lamEIdKey = mkPreludeMiscIdUnique 248
tupEIdKey = mkPreludeMiscIdUnique 249
+unboxedTupEIdKey = mkPreludeMiscIdUnique 263
condEIdKey = mkPreludeMiscIdUnique 250
letEIdKey = mkPreludeMiscIdUnique 251
caseEIdKey = mkPreludeMiscIdUnique 252
varStrictTKey = mkPreludeMiscIdUnique 287
-- data Type = ...
-forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, arrowTIdKey,
+forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,
listTIdKey, appTIdKey, sigTIdKey :: Unique
forallTIdKey = mkPreludeMiscIdUnique 290
varTIdKey = mkPreludeMiscIdUnique 291
conTIdKey = mkPreludeMiscIdUnique 292
tupleTIdKey = mkPreludeMiscIdUnique 294
+unboxedTupleTIdKey = mkPreludeMiscIdUnique 361
arrowTIdKey = mkPreludeMiscIdUnique 295
listTIdKey = mkPreludeMiscIdUnique 296
appTIdKey = mkPreludeMiscIdUnique 293
stdCallIdKey = mkPreludeMiscIdUnique 301
-- data Safety = ...
-unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique
+unsafeIdKey, safeIdKey, threadsafeIdKey, interruptibleIdKey :: Unique
unsafeIdKey = mkPreludeMiscIdUnique 305
safeIdKey = mkPreludeMiscIdUnique 306
threadsafeIdKey = mkPreludeMiscIdUnique 307
+interruptibleIdKey = mkPreludeMiscIdUnique 308
-- data InlineSpec =
inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
projects / ghc-hetmet.git / blobdiff