mirror of
https://github.com/google/ghc-source-gen.git
synced 2024-09-11 22:07:09 +03:00
Parenthesize patterns in bindings on older GHC. (#37)
This commit is contained in:
parent
92fad84066
commit
b2a6ff551b
@ -18,6 +18,7 @@ import SrcLoc (Located)
|
||||
import PlaceHolder (PlaceHolder(..))
|
||||
#endif
|
||||
|
||||
import GHC.SourceGen.Pat.Internal (parenthesize)
|
||||
import GHC.SourceGen.Syntax.Internal
|
||||
|
||||
-- | A binding definition inside of a @let@ or @where@ clause.
|
||||
@ -85,7 +86,8 @@ matchGroup context matches =
|
||||
Generated
|
||||
where
|
||||
mkMatch :: RawMatch -> Match' (Located HsExpr')
|
||||
mkMatch r = noExt Match context (map builtPat $ rawMatchPats r)
|
||||
mkMatch r = noExt Match context
|
||||
(map builtPat $ map parenthesize $ rawMatchPats r)
|
||||
#if !MIN_VERSION_ghc(8,4,0)
|
||||
-- The GHC docs say: "A type signature for the result of the match."
|
||||
-- The parsing step produces 'Nothing' for this field.
|
||||
|
@ -17,13 +17,11 @@ module GHC.SourceGen.Pat
|
||||
, sigP
|
||||
) where
|
||||
|
||||
import SrcLoc (unLoc)
|
||||
import HsTypes
|
||||
import HsPat hiding (LHsRecField')
|
||||
|
||||
import GHC.SourceGen.Name.Internal
|
||||
import GHC.SourceGen.Overloaded (par)
|
||||
import GHC.SourceGen.Expr.Internal (litNeedsParen, overLitNeedsParen)
|
||||
import GHC.SourceGen.Pat.Internal
|
||||
import GHC.SourceGen.Syntax.Internal
|
||||
import GHC.SourceGen.Type.Internal (sigWcType)
|
||||
|
||||
@ -48,32 +46,6 @@ conP :: RdrNameStr -> [Pat'] -> Pat'
|
||||
conP c xs = ConPatIn (valueRdrName c) $ PrefixCon
|
||||
$ map (builtPat . parenthesize) xs
|
||||
|
||||
-- Note: GHC>=8.6 inserts parentheses automatically when pretty-printing patterns.
|
||||
-- When we stop supporting lower versions, we may be able to simplify this.
|
||||
parenthesize :: Pat' -> Pat'
|
||||
parenthesize p
|
||||
| needsPar p = par p
|
||||
| otherwise = p
|
||||
|
||||
needsPar :: Pat' -> Bool
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
needsPar (LitPat _ l) = litNeedsParen l
|
||||
needsPar (NPat _ l _ _) = overLitNeedsParen $ unLoc l
|
||||
#else
|
||||
needsPar (LitPat l) = litNeedsParen l
|
||||
needsPar (NPat l _ _ _) = overLitNeedsParen $ unLoc l
|
||||
#endif
|
||||
needsPar (ConPatIn _ (PrefixCon xs)) = not $ null xs
|
||||
needsPar (ConPatIn _ (InfixCon _ _)) = True
|
||||
needsPar ConPatOut{} = True
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
needsPar SigPat{} = True
|
||||
#else
|
||||
needsPar SigPatIn{} = True
|
||||
needsPar SigPatOut{} = True
|
||||
#endif
|
||||
needsPar _ = False
|
||||
|
||||
recordConP :: RdrNameStr -> [(RdrNameStr, Pat')] -> Pat'
|
||||
recordConP c fs
|
||||
= ConPatIn (valueRdrName c)
|
||||
|
40
src/GHC/SourceGen/Pat/Internal.hs
Normal file
40
src/GHC/SourceGen/Pat/Internal.hs
Normal file
@ -0,0 +1,40 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module GHC.SourceGen.Pat.Internal where
|
||||
|
||||
import HsPat (Pat(..))
|
||||
import HsTypes (HsConDetails(..))
|
||||
|
||||
import GHC.SourceGen.Expr.Internal (litNeedsParen, overLitNeedsParen)
|
||||
import GHC.SourceGen.Syntax.Internal
|
||||
import SrcLoc (unLoc)
|
||||
|
||||
-- Note: GHC>=8.6 inserts parentheses automatically when pretty-printing patterns.
|
||||
-- When we stop supporting lower versions, we may be able to simplify this.
|
||||
parenthesize :: Pat' -> Pat'
|
||||
parenthesize p
|
||||
| needsPar p = parPat p
|
||||
| otherwise = p
|
||||
|
||||
|
||||
needsPar :: Pat' -> Bool
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
needsPar (LitPat _ l) = litNeedsParen l
|
||||
needsPar (NPat _ l _ _) = overLitNeedsParen $ unLoc l
|
||||
#else
|
||||
needsPar (LitPat l) = litNeedsParen l
|
||||
needsPar (NPat l _ _ _) = overLitNeedsParen $ unLoc l
|
||||
#endif
|
||||
needsPar (ConPatIn _ (PrefixCon xs)) = not $ null xs
|
||||
needsPar (ConPatIn _ (InfixCon _ _)) = True
|
||||
needsPar ConPatOut{} = True
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
needsPar SigPat{} = True
|
||||
#else
|
||||
needsPar SigPatIn{} = True
|
||||
needsPar SigPatOut{} = True
|
||||
#endif
|
||||
needsPar _ = False
|
||||
|
||||
parPat :: Pat' -> Pat'
|
||||
parPat = noExt ParPat . builtPat
|
||||
|
@ -174,6 +174,13 @@ exprsTest dflags = testGroup "Expr"
|
||||
, "x + y {b = x}"
|
||||
:~ op (var "x") "+" (recordUpd (var "y") [("b", var "x")])
|
||||
]
|
||||
, test "let"
|
||||
[ "let x = 1 in x" :~ let' [valBind "x" $ int 1] (var "x")
|
||||
, "let f x = 1 in f" :~
|
||||
let' [ funBind "f" $ match [var "x"] $ int 1] (var "f")
|
||||
, "let f (A x) = 1 in f" :~
|
||||
let' [ funBind "f" $ match [conP "A" [var "x"]] $ int 1] (var "f")
|
||||
]
|
||||
]
|
||||
where
|
||||
test = testExprs dflags
|
||||
@ -222,6 +229,7 @@ declsTest dflags = testGroup "Decls"
|
||||
[ guard (var "x") (var "False")
|
||||
, guard (var "otherwise") (var "True")
|
||||
]
|
||||
, "f (A x) = 1" :~ funBind "f" $ match [conP "A" [var "x"]] (int 1)
|
||||
]
|
||||
, test "tyFamInst"
|
||||
[ "type instance Elt String = Char"
|
||||
|
Loading…
Reference in New Issue
Block a user