diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2016-11-13 23:03:49 +0200 |
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2016-11-13 23:03:49 +0200 |
| commit | c1fe13d3232224031f666a1157a957fc1835c987 (patch) | |
| tree | 87faff3288f54a971070511a2ef8e56df9c864e6 | |
| parent | 379da5809e8b2d6019b68340f61b326a49b58b24 (diff) | |
| download | haskell-wip/T3384.tar.gz | |
Adding parens into generically generated codewip/T3384
And some other bits
27 files changed, 757 insertions, 79 deletions
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 840106c47c..252d6c2b62 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -1068,7 +1068,14 @@ instance (OutputableBndrId name) => Outputable (HsDerivingClause name) where , deriv_clause_tys = L _ dct }) = hsep [ text "deriving" , ppDerivStrategy dcs - , parens (interpp'SP dct) ] + , pp_dct dct ] + where + -- This complexity is to distinguish between + -- deriving Show + -- deriving (Show) + pp_dct [a@(HsIB _ (L _ HsAppsTy{}))] = parens (ppr a) + pp_dct [a] = ppr a + pp_dct _ = parens (interpp'SP dct) data NewOrData = NewType -- ^ @newtype Blah ...@ diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index ec5578f36d..0042f51d44 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -670,9 +670,9 @@ hsPatNeedsParens (LitPat {}) = False hsPatNeedsParens (NPat {}) = False conPatNeedsParens :: HsConDetails a b -> Bool -conPatNeedsParens (PrefixCon args) = not (null args) -conPatNeedsParens (InfixCon {}) = True -conPatNeedsParens (RecCon {}) = True +conPatNeedsParens (PrefixCon {}) = False +conPatNeedsParens (InfixCon {}) = True +conPatNeedsParens (RecCon {}) = False {- % Collect all EvVars from all constructor patterns diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index de7736004d..8f52ea0c15 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -49,7 +49,7 @@ module HsUtils( -- Patterns mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat, nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat, - nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, + nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, nlParPat, mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, -- Types @@ -206,6 +206,8 @@ mkParPat :: LPat name -> LPat name mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp) | otherwise = lp +nlParPat :: LPat name -> LPat name +nlParPat p = noLoc (ParPat p) ------------------------------- -- These are the bits of syntax that contain rebindable names diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 2c90086c56..e950b09d27 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1444,11 +1444,11 @@ binds :: { Located ([AddAnn],Located (HsLocalBinds RdrName)) } ,sL1 $1 $ HsValBinds val_binds)) } } | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3] - ,sL1 $2 $ HsIPBinds (IPBinds (unLoc $2) + ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2) emptyTcEvBinds)) } | vocurly dbinds close { L (getLoc $2) ([] - ,sL1 $2 $ HsIPBinds (IPBinds (unLoc $2) + ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2) emptyTcEvBinds)) } diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 50e4c54d50..f71c55033a 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -198,8 +198,8 @@ gen_Eq_binds loc tycon ------------------------------------------------------------------ pats_etc data_con = let - con1_pat = nlConVarPat data_con_RDR as_needed - con2_pat = nlConVarPat data_con_RDR bs_needed + con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed + con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed data_con_RDR = getRdrName data_con con_arity = length tys_needed diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs index c57740324e..74c5a8096b 100644 --- a/compiler/typecheck/TcGenFunctor.hs +++ b/compiler/typecheck/TcGenFunctor.hs @@ -310,7 +310,10 @@ mkSimpleConMatch :: Monad m => HsMatchContext RdrName mkSimpleConMatch ctxt fold extra_pats con insides = do let con_name = getRdrName con let vars_needed = takeList insides as_RDRs - let pat = nlConVarPat con_name vars_needed + let bare_pat = nlConVarPat con_name vars_needed + let pat = if null vars_needed + then bare_pat + else nlParPat bare_pat rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed)) return $ mkMatch ctxt (extra_pats ++ [pat]) rhs (noLoc emptyLocalBinds) diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index 0c65f686c2..6c4fcc382b 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -331,7 +331,8 @@ mkBindsRep gk tycon = -- to save some allocations during typechecking. -- See Note [Generics compilation speed tricks] from_eqn = mkHsCaseAlt x_Pat $ mkM1_E $ nlHsCase x_Expr from_matches - to_eqn = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches + to_eqn = mkHsCaseAlt (mkM1_P x_Pat) + $ nlHsCase x_Expr to_matches from_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts] to_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts ] @@ -760,8 +761,8 @@ genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName genLR_P i n p | n == 0 = error "impossible" | n == 1 = p - | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i (div n 2) p] - | otherwise = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p] + | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i (div n 2) p] + | otherwise = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p] where m = div n 2 -- Generates the L1/R1 sum expression @@ -832,12 +833,12 @@ mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars) -- These M1s are meta-information for the constructor where appVars = unzipWith (wrapArg_P gk) varTys - prod a b = prodDataCon_RDR `nlConPat` [a,b] + prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b] wrapArg_P :: GenericKind -> RdrName -> Type -> LPat RdrName -wrapArg_P Gen0 v ty = mkM1_P (boxRepRDR ty `nlConVarPat` [v]) +wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v]) -- This M1 is meta-information for the selector -wrapArg_P Gen1 v _ = m1DataCon_RDR `nlConVarPat` [v] +wrapArg_P Gen1 v _ = nlParPat $ m1DataCon_RDR `nlConVarPat` [v] mkGenericLocal :: US -> RdrName mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) @@ -855,7 +856,7 @@ mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e mkM1_P :: LPat RdrName -> LPat RdrName -mkM1_P p = m1DataCon_RDR `nlConPat` [p] +mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p] nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName nlHsCompose x y = compose_RDR `nlHsApps` [x, y] diff --git a/testsuite/tests/generics/GenDerivOutput.stderr b/testsuite/tests/generics/GenDerivOutput.stderr index ed575de957..3e1f175178 100644 --- a/testsuite/tests/generics/GenDerivOutput.stderr +++ b/testsuite/tests/generics/GenDerivOutput.stderr @@ -15,10 +15,10 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.K1 g2))))) GHC.Generics.to (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> GenDerivOutput.Nil - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) -> GenDerivOutput.Cons g1 g2 instance GHC.Generics.Generic1 GenDerivOutput.List where @@ -35,10 +35,10 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.Rec1 g2))))) GHC.Generics.to1 (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> GenDerivOutput.Nil - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> GenDerivOutput.Cons (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) @@ -61,10 +61,10 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.K1 g2))))) GHC.Generics.to (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> GenDerivOutput.Empty - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) -> GenDerivOutput.Rose g1 g2 instance GHC.Generics.Generic1 GenDerivOutput.Rose where @@ -83,10 +83,10 @@ Derived class instances: GHC.Generics.Comp1 (GHC.Base.fmap GHC.Generics.Rec1) g2))))) GHC.Generics.to1 (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> GenDerivOutput.Empty - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> GenDerivOutput.Rose (GHC.Generics.unPar1 g1) ((GHC.Base..) diff --git a/testsuite/tests/generics/GenDerivOutput1_0.stderr b/testsuite/tests/generics/GenDerivOutput1_0.stderr index e509c406c5..bf9cf1590c 100644 --- a/testsuite/tests/generics/GenDerivOutput1_0.stderr +++ b/testsuite/tests/generics/GenDerivOutput1_0.stderr @@ -15,10 +15,10 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.Rec1 g2))))) GHC.Generics.to1 (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> GenDerivOutput1_0.Nil - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> GenDerivOutput1_0.Cons (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) diff --git a/testsuite/tests/generics/GenDerivOutput1_1.stderr b/testsuite/tests/generics/GenDerivOutput1_1.stderr index 6b524bd81e..5f4e7e241d 100644 --- a/testsuite/tests/generics/GenDerivOutput1_1.stderr +++ b/testsuite/tests/generics/GenDerivOutput1_1.stderr @@ -15,10 +15,10 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.Rec1 g2))))) GHC.Generics.to1 (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> CanDoRep1_1.D0d - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> CanDoRep1_1.D1d (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) @@ -36,10 +36,10 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.K1 g2))))) GHC.Generics.to (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> CanDoRep1_1.D0d - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) -> CanDoRep1_1.D1d g1 g2 instance GHC.Generics.Generic (CanDoRep1_1.Dc a) where @@ -56,10 +56,10 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.K1 g2))))) GHC.Generics.to (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> CanDoRep1_1.D0c - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) -> CanDoRep1_1.D1c g1 g2 instance GHC.Generics.Generic1 CanDoRep1_1.Db where @@ -76,10 +76,10 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.Rec1 g2))))) GHC.Generics.to1 (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> CanDoRep1_1.D0b - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> CanDoRep1_1.D1b (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) @@ -96,9 +96,10 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.K1 g2))))) GHC.Generics.to (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) -> CanDoRep1_1.D0 - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) + -> CanDoRep1_1.D0 + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) -> CanDoRep1_1.D1 g1 g2 instance GHC.Generics.Generic1 CanDoRep1_1.Da where @@ -114,9 +115,10 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.Rec1 g2))))) GHC.Generics.to1 (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) -> CanDoRep1_1.D0 - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) + -> CanDoRep1_1.D0 + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> CanDoRep1_1.D1 (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) instance GHC.Generics.Generic (CanDoRep1_1.Db a) where @@ -133,10 +135,10 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.K1 g2))))) GHC.Generics.to (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> CanDoRep1_1.D0b - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) -> CanDoRep1_1.D1b g1 g2 instance GHC.Generics.Generic1 CanDoRep1_1.Dc where @@ -153,10 +155,10 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.Rec1 g2))))) GHC.Generics.to1 (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> CanDoRep1_1.D0c - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> CanDoRep1_1.D1c (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) diff --git a/testsuite/tests/generics/T10604/T10604_deriving.stderr b/testsuite/tests/generics/T10604/T10604_deriving.stderr index 948ce0d462..d90c2733b1 100644 --- a/testsuite/tests/generics/T10604/T10604_deriving.stderr +++ b/testsuite/tests/generics/T10604/T10604_deriving.stderr @@ -33,7 +33,7 @@ Derived class instances: T10604_deriving.Proxy -> GHC.Generics.M1 GHC.Generics.U1 }) GHC.Generics.to (GHC.Generics.M1 x) = case x of { - GHC.Generics.M1 GHC.Generics.U1 -> T10604_deriving.Proxy } + (GHC.Generics.M1 GHC.Generics.U1) -> T10604_deriving.Proxy } instance GHC.Generics.Generic1 k (T10604_deriving.Proxy k) where GHC.Generics.from1 x @@ -42,7 +42,7 @@ Derived class instances: T10604_deriving.Proxy -> GHC.Generics.M1 GHC.Generics.U1 }) GHC.Generics.to1 (GHC.Generics.M1 x) = case x of { - GHC.Generics.M1 GHC.Generics.U1 -> T10604_deriving.Proxy } + (GHC.Generics.M1 GHC.Generics.U1) -> T10604_deriving.Proxy } instance GHC.Generics.Generic (T10604_deriving.Wrap a) where GHC.Generics.from x @@ -52,7 +52,7 @@ Derived class instances: -> GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)) }) GHC.Generics.to (GHC.Generics.M1 x) = case x of { - GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) -> T10604_deriving.Wrap g1 } instance GHC.Generics.Generic1 @@ -64,7 +64,7 @@ Derived class instances: -> GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.Rec1 g1)) }) GHC.Generics.to1 (GHC.Generics.M1 x) = case x of { - GHC.Generics.M1 (GHC.Generics.M1 g1) + (GHC.Generics.M1 (GHC.Generics.M1 g1)) -> T10604_deriving.Wrap (GHC.Generics.unRec1 g1) } instance forall k (a :: k -> GHC.Types.*). @@ -76,7 +76,7 @@ Derived class instances: -> GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)) }) GHC.Generics.to (GHC.Generics.M1 x) = case x of { - GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) -> T10604_deriving.Wrap2 g1 } instance GHC.Generics.Generic1 @@ -91,7 +91,7 @@ Derived class instances: GHC.Generics.Comp1 (GHC.Base.fmap GHC.Generics.Rec1) g1)) }) GHC.Generics.to1 (GHC.Generics.M1 x) = case x of { - GHC.Generics.M1 (GHC.Generics.M1 g1) + (GHC.Generics.M1 (GHC.Generics.M1 g1)) -> T10604_deriving.Wrap2 ((GHC.Base..) (GHC.Base.fmap GHC.Generics.unRec1) GHC.Generics.unComp1 g1) } @@ -115,11 +115,11 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.K1 g2))))) GHC.Generics.to (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) + (GHC.Generics.L1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) -> T10604_deriving.Prod1 g1 g2 - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) -> T10604_deriving.Prod2 g1 g2 instance GHC.Generics.Generic1 @@ -141,12 +141,12 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.Rec1 g2))))) GHC.Generics.to1 (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + (GHC.Generics.L1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> T10604_deriving.Prod1 (GHC.Generics.unRec1 g1) (GHC.Generics.unRec1 g2) - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> T10604_deriving.Prod2 (GHC.Generics.unRec1 g1) (GHC.Generics.unRec1 g2) @@ -162,9 +162,9 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)))) GHC.Generics.to (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) + (GHC.Generics.L1 (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)))) -> T10604_deriving.Starify1 g1 - GHC.Generics.R1 (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) + (GHC.Generics.R1 (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)))) -> T10604_deriving.Starify2 g1 instance GHC.Generics.Generic1 * T10604_deriving.Starify where @@ -179,9 +179,9 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)))) GHC.Generics.to1 (GHC.Generics.M1 x) = case x of - GHC.Generics.L1 (GHC.Generics.M1 (GHC.Generics.M1 g1)) + (GHC.Generics.L1 (GHC.Generics.M1 (GHC.Generics.M1 g1))) -> T10604_deriving.Starify1 (GHC.Generics.unPar1 g1) - GHC.Generics.R1 (GHC.Generics.M1 (GHC.Generics.M1 g1)) + (GHC.Generics.R1 (GHC.Generics.M1 (GHC.Generics.M1 g1))) -> T10604_deriving.Starify2 (GHC.Generics.unK1 g1) diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr index 684a6f072a..060dd06ad2 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr @@ -3,7 +3,7 @@ module T11768 where data Foo = Foo - deriving (Eq Documenting a single type) + deriving Eq Documenting a single type data Bar = Bar deriving (Eq Documenting one of multiple types, Ord) diff --git a/testsuite/tests/printer/.gitignore b/testsuite/tests/printer/.gitignore index 03f905fb5b..b10fba6c30 100644 --- a/testsuite/tests/printer/.gitignore +++ b/testsuite/tests/printer/.gitignore @@ -1,7 +1,9 @@ *.ast *.ppr.hs +*.ppr *.o *.hi *.out Ppr003 Ppr004 +Ppr016 diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile index 0c4ad7e2e1..a809a43301 100644 --- a/testsuite/tests/printer/Makefile +++ b/testsuite/tests/printer/Makefile @@ -57,3 +57,27 @@ ppr012: .PHONY: ppr013 ppr013: $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr013.hs + +.PHONY: ppr014 +ppr014: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr014.hs + +.PHONY: ppr015 +ppr015: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr015.hs + +.PHONY: ppr016 +ppr016: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr016.hs + +.PHONY: ppr017 +ppr017: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr017.hs + +.PHONY: ppr018 +ppr018: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr018.hs + +.PHONY: ppr019 +ppr019: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr019.hs diff --git a/testsuite/tests/printer/Ppr014.hs b/testsuite/tests/printer/Ppr014.hs new file mode 100644 index 0000000000..c0448688ba --- /dev/null +++ b/testsuite/tests/printer/Ppr014.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +-- from https://ocharles.org.uk/blog/guest-posts/2014-12-19-existential-quantification.html + +data HashMap k v = HM -- ... -- actual implementation + +class Hashable v where + h :: v -> Int + +data HashMapM hm = HashMapM + { empty :: forall k v . hm k v + , lookup :: Hashable k => k -> hm k v -> Maybe v + , insert :: Hashable k => k -> v -> hm k v -> hm k v + , union :: Hashable k => hm k v -> hm k v -> hm k v + } + + +data HashMapE = forall hm . HashMapE (HashMapM hm) + +-- public +mkHashMapE :: Int -> HashMapE +mkHashMapE = HashMapE . mkHashMapM + +-- private +mkHashMapM :: Int -> HashMapM HashMap +mkHashMapM salt = HashMapM { {- implementation -} } + +instance Hashable String where + +type Name = String +data Gift = G String + +giraffe :: Gift +giraffe = G "giraffe" + +addGift :: HashMapM hm -> hm Name Gift -> hm Name Gift +addGift mod gifts = + let + HashMapM{..} = mod + in + insert "Ollie" giraffe gifts + +-- ------------------------------- + +santa'sSecretSalt = undefined +sendGiftToOllie = undefined +traverse_ = undefined + +sendGifts = + case mkHashMapE santa'sSecretSalt of + HashMapE (mod@HashMapM{..}) -> + let + gifts = addGift mod empty + in + traverse_ sendGiftToOllie $ lookup "Ollie" gifts diff --git a/testsuite/tests/printer/Ppr014.stderr b/testsuite/tests/printer/Ppr014.stderr new file mode 100644 index 0000000000..d7ef8c588b --- /dev/null +++ b/testsuite/tests/printer/Ppr014.stderr @@ -0,0 +1,76 @@ + +Ppr014.hs:16:24: error: Not in scope: type variable ‘k’ + +Ppr014.hs:16:29: error: Not in scope: type variable ‘k’ + +Ppr014.hs:16:37: error: Not in scope: type variable ‘k’ + +Ppr014.hs:16:39: error: Not in scope: type variable ‘v’ + +Ppr014.hs:16:50: error: Not in scope: type variable ‘v’ + +Ppr014.hs:17:24: error: Not in scope: type variable ‘k’ + +Ppr014.hs:17:29: error: Not in scope: type variable ‘k’ + +Ppr014.hs:17:34: error: Not in scope: type variable ‘v’ + +Ppr014.hs:17:42: error: Not in scope: type variable ‘k’ + +Ppr014.hs:17:44: error: Not in scope: type variable ‘v’ + +Ppr014.hs:17:52: error: Not in scope: type variable ‘k’ + +Ppr014.hs:17:54: error: Not in scope: type variable ‘v’ + +Ppr014.hs:18:24: error: Not in scope: type variable ‘k’ + +Ppr014.hs:18:32: error: Not in scope: type variable ‘k’ + +Ppr014.hs:18:34: error: Not in scope: type variable ‘v’ + +Ppr014.hs:18:42: error: Not in scope: type variable ‘k’ + +Ppr014.hs:18:44: error: Not in scope: type variable ‘v’ + +Ppr014.hs:18:52: error: Not in scope: type variable ‘k’ + +Ppr014.hs:18:54: error: Not in scope: type variable ‘v’ + +Ppr014.ppr.hs:11:34: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:11:39: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:11:47: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:11:49: error: Not in scope: type variable ‘v’ + +Ppr014.ppr.hs:11:60: error: Not in scope: type variable ‘v’ + +Ppr014.ppr.hs:12:34: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:12:39: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:12:44: error: Not in scope: type variable ‘v’ + +Ppr014.ppr.hs:12:52: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:12:54: error: Not in scope: type variable ‘v’ + +Ppr014.ppr.hs:12:62: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:12:64: error: Not in scope: type variable ‘v’ + +Ppr014.ppr.hs:13:33: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:13:41: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:13:43: error: Not in scope: type variable ‘v’ + +Ppr014.ppr.hs:13:51: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:13:53: error: Not in scope: type variable ‘v’ + +Ppr014.ppr.hs:13:61: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:13:63: error: Not in scope: type variable ‘v’ diff --git a/testsuite/tests/printer/Ppr015.hs b/testsuite/tests/printer/Ppr015.hs new file mode 100644 index 0000000000..2fad6041ed --- /dev/null +++ b/testsuite/tests/printer/Ppr015.hs @@ -0,0 +1,7 @@ +module ExprPragmas where + +a = {-# SCC "name" #-} 0x5 + +b = {-# SCC foo #-} 006 + +c = {-# GENERATED "foobar" 1 : 2 - 3 : 4 #-} 0.00 diff --git a/testsuite/tests/printer/Ppr016.hs b/testsuite/tests/printer/Ppr016.hs new file mode 100644 index 0000000000..630045c0b2 --- /dev/null +++ b/testsuite/tests/printer/Ppr016.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ImplicitParams #-} + +explicit :: ((?above :: q, ?below :: a -> q) => b) -> q -> (a -> q) -> b +explicit x ab be = x where ?above = ab; ?below = be diff --git a/testsuite/tests/printer/Ppr016.stderr b/testsuite/tests/printer/Ppr016.stderr new file mode 100644 index 0000000000..2d508fa4dd --- /dev/null +++ b/testsuite/tests/printer/Ppr016.stderr @@ -0,0 +1,14 @@ + +Ppr016.hs:3:13: error: + • Illegal qualified type: (?above::q, ?below::a -> q) => b + Perhaps you intended to use RankNTypes or Rank2Types + • In the type signature: + explicit :: ((?above :: q, ?below :: a -> q) => b) + -> q -> (a -> q) -> b + +Ppr016.ppr.hs:3:3: error: + • Illegal qualified type: (?above::q, ?below::a -> q) => b + Perhaps you intended to use RankNTypes or Rank2Types + • In the type signature: + explicit :: ((?above :: q, ?below :: a -> q) => b) + -> q -> (a -> q) -> b diff --git a/testsuite/tests/printer/Ppr017.hs b/testsuite/tests/printer/Ppr017.hs new file mode 100644 index 0000000000..091ffee048 --- /dev/null +++ b/testsuite/tests/printer/Ppr017.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ExplicitNamespaces #-} +module Imports( f, type (+), pattern Single ) where + +import GHC.TypeLits + +pattern Single x = [x] + +f = undefined diff --git a/testsuite/tests/printer/Ppr017.stderr b/testsuite/tests/printer/Ppr017.stderr new file mode 100644 index 0000000000..4f92e6c472 --- /dev/null +++ b/testsuite/tests/printer/Ppr017.stderr @@ -0,0 +1,3 @@ + +Ppr017.ppr.hs:4:22: error: + Not in scope: type constructor or class ‘Single’ diff --git a/testsuite/tests/printer/Ppr018.hs b/testsuite/tests/printer/Ppr018.hs new file mode 100644 index 0000000000..c05ce66c8a --- /dev/null +++ b/testsuite/tests/printer/Ppr018.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} + +data Foo a = F Int | A a + deriving Show + +data Foo1 a = F1 Int | A1 a + deriving (Show) + +data Foo2 a = F2 Int | A2 a + deriving (Show, Eq) + +data FooStock = FS Int + deriving stock Show + +data FooAnyClass = Fa Int + deriving anyclass Show + +newtype FooNewType = Fn Int + deriving newtype (Show) diff --git a/testsuite/tests/printer/Ppr018.stderr b/testsuite/tests/printer/Ppr018.stderr new file mode 100644 index 0000000000..7172b4e8be --- /dev/null +++ b/testsuite/tests/printer/Ppr018.stderr @@ -0,0 +1,12 @@ + +Ppr018.hs:20:21: + Can't make a derived instance of + ‘Show FooNewType’ with the newtype strategy: + Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension + In the newtype declaration for ‘FooNewType’ + +Ppr018.ppr.hs:20:21: + Can't make a derived instance of + ‘Show FooNewType’ with the newtype strategy: + Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension + In the newtype declaration for ‘FooNewType’ diff --git a/testsuite/tests/printer/Ppr019.hs b/testsuite/tests/printer/Ppr019.hs new file mode 100644 index 0000000000..c934cc5ccc --- /dev/null +++ b/testsuite/tests/printer/Ppr019.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, + CPP #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE RoleAnnotations #-} +#endif + +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.IO.Internal +-- Copyright : (c) The University of Glasgow 2001-2012 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (uses Data.Array.Base) +-- +-- Mutable boxed and unboxed arrays in the IO monad. +-- +----------------------------------------------------------------------------- + +module Data.Array.IO.Internals ( + IOArray(..), -- instance of: Eq, Typeable + IOUArray(..), -- instance of: Eq, Typeable + castIOUArray, -- :: IOUArray ix a -> IO (IOUArray ix b) + unsafeThawIOUArray, + ) where + +import Data.Int +import Data.Word +import Data.Typeable + +import Control.Monad.ST ( RealWorld, stToIO ) +import Foreign.Ptr ( Ptr, FunPtr ) +import Foreign.StablePtr ( StablePtr ) + +#if __GLASGOW_HASKELL__ < 711 +import Data.Ix +#endif +import Data.Array.Base + +import GHC.IOArray (IOArray(..)) + +----------------------------------------------------------------------------- +-- Flat unboxed mutable arrays (IO monad) + +-- | Mutable, unboxed, strict arrays in the 'IO' monad. The type +-- arguments are as follows: +-- +-- * @i@: the index type of the array (should be an instance of 'Ix') +-- +-- * @e@: the element type of the array. Only certain element types +-- are supported: see "Data.Array.MArray" for a list of instances. +-- +newtype IOUArray i e = IOUArray (STUArray RealWorld i e) + deriving Typeable +#if __GLASGOW_HASKELL__ >= 708 +-- Both parameters have class-based invariants. See also #9220. +type role IOUArray nominal nominal +#endif + +instance Eq (IOUArray i e) where + IOUArray s1 == IOUArray s2 = s1 == s2 + +instance MArray IOUArray Bool IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Char IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray (Ptr a) IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray (FunPtr a) IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Float IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Double IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray (StablePtr a) IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int8 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int16 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int32 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int64 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word8 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word16 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word32 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word64 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +-- | Casts an 'IOUArray' with one element type into one with a +-- different element type. All the elements of the resulting array +-- are undefined (unless you know what you\'re doing...). +castIOUArray :: IOUArray ix a -> IO (IOUArray ix b) +castIOUArray (IOUArray marr) = stToIO $ do + marr' <- castSTUArray marr + return (IOUArray marr') + +{-# INLINE unsafeThawIOUArray #-} +#if __GLASGOW_HASKELL__ >= 711 +unsafeThawIOUArray :: UArray ix e -> IO (IOUArray ix e) +#else +unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e) +#endif +unsafeThawIOUArray arr = stToIO $ do + marr <- unsafeThawSTUArray arr + return (IOUArray marr) + +{-# RULES +"unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray + #-} + +#if __GLASGOW_HASKELL__ >= 711 +thawIOUArray :: UArray ix e -> IO (IOUArray ix e) +#else +thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e) +#endif +thawIOUArray arr = stToIO $ do + marr <- thawSTUArray arr + return (IOUArray marr) + +{-# RULES +"thaw/IOUArray" thaw = thawIOUArray + #-} + +{-# INLINE unsafeFreezeIOUArray #-} +#if __GLASGOW_HASKELL__ >= 711 +unsafeFreezeIOUArray :: IOUArray ix e -> IO (UArray ix e) +#else +unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e) +#endif +unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr) + +{-# RULES +"unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray + #-} + +#if __GLASGOW_HASKELL__ >= 711 +freezeIOUArray :: IOUArray ix e -> IO (UArray ix e) +#else +freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e) +#endif +freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr) + +{-# RULES +"freeze/IOUArray" freeze = freezeIOUArray + #-} diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T index c2adc0088c..d3c14f2566 100644 --- a/testsuite/tests/printer/all.T +++ b/testsuite/tests/printer/all.T @@ -11,3 +11,9 @@ test('Ppr010', normal, run_command, ['$MAKE -s --no-print-directory ppr010']) test('Ppr011', normal, run_command, ['$MAKE -s --no-print-directory ppr011']) test('Ppr012', normal, run_command, ['$MAKE -s --no-print-directory ppr012']) test('Ppr013', normal, run_command, ['$MAKE -s --no-print-directory ppr013']) +test('Ppr014', normal, run_command, ['$MAKE -s --no-print-directory ppr014']) +test('Ppr015', normal, run_command, ['$MAKE -s --no-print-directory ppr015']) +test('Ppr016', normal, run_command, ['$MAKE -s --no-print-directory ppr016']) +test('Ppr017', normal, run_command, ['$MAKE -s --no-print-directory ppr017']) +test('Ppr018', normal, run_command, ['$MAKE -s --no-print-directory ppr018']) +test('Ppr019', normal, run_command, ['$MAKE -s --no-print-directory ppr019']) diff --git a/testsuite/tests/th/T10598_TH.stderr b/testsuite/tests/th/T10598_TH.stderr index 9277da5c68..4c5d9ed290 100644 --- a/testsuite/tests/th/T10598_TH.stderr +++ b/testsuite/tests/th/T10598_TH.stderr @@ -33,9 +33,9 @@ T10598_TH.hs:(27,3)-(42,50): Splicing declarations ======> newtype Foo = MkFoo Int - deriving stock (Eq) - deriving anyclass (C) - deriving newtype (Read) + deriving stock Eq + deriving anyclass C + deriving newtype Read deriving stock instance Ord Foo deriving anyclass instance D Foo deriving newtype instance Show Foo diff --git a/testsuite/tests/th/T3899a.hs b/testsuite/tests/th/T3899a.hs index 2ac985136f..1af6bba76c 100644 --- a/testsuite/tests/th/T3899a.hs +++ b/testsuite/tests/th/T3899a.hs @@ -10,5 +10,5 @@ data Nil = Nil nestedTuple n = do xs <- replicateM n (newName "x") - return $ LamE [foldr (\v prev -> ConP 'Cons [VarP v,prev]) (ConP 'Nil []) xs] + return $ LamE [foldr (\v prev -> ParensP (ConP 'Cons [VarP v,prev])) (ConP 'Nil []) xs] (TupE $ map VarE xs) |