summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/hsSyn/HsDecls.hs9
-rw-r--r--compiler/hsSyn/HsPat.hs6
-rw-r--r--compiler/hsSyn/HsUtils.hs4
-rw-r--r--compiler/parser/Parser.y4
-rw-r--r--compiler/typecheck/TcGenDeriv.hs4
-rw-r--r--compiler/typecheck/TcGenFunctor.hs5
-rw-r--r--compiler/typecheck/TcGenGenerics.hs15
7 files changed, 30 insertions, 17 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]
View Lorry Controller Status