X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMeta.hs;h=5da376b574df867fff7cf993db49d17cd04a7459;hp=6b3d216f266cae0de6f138e6abbb1a2cfe1f57ce;hb=6ea06bbf08517d9805feb82df65cc56ecbaf23a4;hpb=241c6ba59c89d491aa4087f754dfcbbca26163f4 diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 6b3d216..5da376b 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -119,7 +119,7 @@ repTopDs group 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 @@ -349,6 +349,7 @@ repCCallConv callConv = notHandled "repCCallConv" (ppr callConv) repSafety :: Safety -> DsM (Core TH.Safety) repSafety PlayRisky = rep2 unsafeName [] +repSafety PlayInterruptible = rep2 interruptibleName [] repSafety (PlaySafe False) = rep2 safeName [] repSafety (PlaySafe True) = rep2 threadsafeName [] @@ -460,15 +461,17 @@ rep_specialise nm ty ispec loc 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 @@ -703,7 +706,7 @@ repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } 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 @@ -956,7 +959,7 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) ; 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 @@ -1035,6 +1038,7 @@ repP (ConPatIn dc details) 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. @@ -1267,6 +1271,9 @@ repPwild = rep2 wildPName [] 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 @@ -1291,7 +1298,7 @@ repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) repTup (MkC es) = rep2 tupEName [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] @@ -1655,13 +1662,14 @@ templateHaskellNames :: [Name] 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, + asPName, wildPName, recPName, listPName, sigPName, viewPName, -- FieldPat fieldPatName, -- Match @@ -1713,6 +1721,7 @@ templateHaskellNames = [ unsafeName, safeName, threadsafeName, + interruptibleName, -- InlineSpec inlineSpecNoPhaseName, inlineSpecPhaseName, -- FunDep @@ -1797,7 +1806,7 @@ rationalLName = libFun (fsLit "rationalL") rationalLIdKey -- data Pat = ... litPName, varPName, tupPName, conPName, infixPName, tildePName, bangPName, - asPName, wildPName, recPName, listPName, sigPName :: Name + asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name litPName = libFun (fsLit "litP") litPIdKey varPName = libFun (fsLit "varP") varPIdKey tupPName = libFun (fsLit "tupP") tupPIdKey @@ -1810,6 +1819,7 @@ wildPName = libFun (fsLit "wildP") wildPIdKey recPName = libFun (fsLit "recP") recPIdKey listPName = libFun (fsLit "listP") listPIdKey sigPName = libFun (fsLit "sigP") sigPIdKey +viewPName = libFun (fsLit "viewP") viewPIdKey -- type FieldPat = ... fieldPatName :: Name @@ -1956,10 +1966,11 @@ cCallName = libFun (fsLit "cCall") cCallIdKey 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 @@ -2074,7 +2085,7 @@ liftStringIdKey = mkPreludeMiscIdUnique 218 -- data Pat = ... litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, - asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique + asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique litPIdKey = mkPreludeMiscIdUnique 220 varPIdKey = mkPreludeMiscIdUnique 221 tupPIdKey = mkPreludeMiscIdUnique 222 @@ -2087,6 +2098,7 @@ wildPIdKey = mkPreludeMiscIdUnique 226 recPIdKey = mkPreludeMiscIdUnique 227 listPIdKey = mkPreludeMiscIdUnique 228 sigPIdKey = mkPreludeMiscIdUnique 229 +viewPIdKey = mkPreludeMiscIdUnique 360 -- type FieldPat = ... fieldPatIdKey :: Unique @@ -2232,10 +2244,11 @@ cCallIdKey = mkPreludeMiscIdUnique 300 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