mirror of
https://github.com/google/ghc-source-gen.git
synced 2024-09-11 22:07:09 +03:00
Add parentheses in more cases. (#34)
- Op applied to argument - patterns (for older GHCs)
This commit is contained in:
parent
4e5bc00b3f
commit
a792e98f49
@ -126,7 +126,7 @@ instance App HsExpr' where
|
||||
PlaceHolder
|
||||
#endif
|
||||
(parenthesizeExprForOp $ builtLoc y)
|
||||
x @@ y = noExt HsApp (builtLoc x)
|
||||
x @@ y = noExt HsApp (parenthesizeExprForOp $ builtLoc x)
|
||||
(parenthesizeExprForApp $ builtLoc y)
|
||||
|
||||
instance App HsType' where
|
||||
@ -135,7 +135,7 @@ instance App HsType' where
|
||||
(typeRdrName o)
|
||||
(parenthesizeTypeForOp $ builtLoc y)
|
||||
x @@ y = noExt HsAppTy
|
||||
(builtLoc x)
|
||||
(parenthesizeTypeForOp $ builtLoc x)
|
||||
(parenthesizeTypeForApp $ builtLoc y)
|
||||
|
||||
class HasTuple e where
|
||||
|
@ -4,6 +4,7 @@
|
||||
-- license that can be found in the LICENSE file or at
|
||||
-- https://developers.google.com/open-source/licenses/bsd
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
-- | This module provides combinators for constructing Haskell patterns.
|
||||
module GHC.SourceGen.Pat
|
||||
( Pat'
|
||||
@ -15,10 +16,13 @@ module GHC.SourceGen.Pat
|
||||
, lazyP
|
||||
) 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.Syntax.Internal
|
||||
|
||||
-- | A wild pattern (@_@).
|
||||
@ -31,7 +35,7 @@ wildP = noExtOrPlaceHolder WildPat
|
||||
-- > =====
|
||||
-- > asP "a" (var "B")
|
||||
asP :: RdrNameStr -> Pat' -> Pat'
|
||||
v `asP` p = noExt AsPat (valueRdrName v) $ builtPat p
|
||||
v `asP` p = noExt AsPat (valueRdrName v) $ builtPat $ parenthesize p
|
||||
|
||||
-- | A pattern constructor.
|
||||
--
|
||||
@ -39,7 +43,34 @@ v `asP` p = noExt AsPat (valueRdrName v) $ builtPat p
|
||||
-- > =====
|
||||
-- > conP "A" [var "b", var "c"]
|
||||
conP :: RdrNameStr -> [Pat'] -> Pat'
|
||||
conP c xs = ConPatIn (valueRdrName c) $ PrefixCon $ map builtPat xs
|
||||
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
|
||||
@ -61,7 +92,7 @@ recordConP c fs
|
||||
-- > =====
|
||||
-- > strictP (var x)
|
||||
strictP :: Pat' -> Pat'
|
||||
strictP = noExt BangPat . builtPat
|
||||
strictP = noExt BangPat . builtPat . parenthesize
|
||||
|
||||
-- | A lazy pattern match.
|
||||
--
|
||||
@ -69,4 +100,4 @@ strictP = noExt BangPat . builtPat
|
||||
-- > =====
|
||||
-- > lazyP (conP "A" [var x])
|
||||
lazyP :: Pat' -> Pat'
|
||||
lazyP = noExt LazyPat . builtPat
|
||||
lazyP = noExt LazyPat . builtPat . parenthesize
|
||||
|
@ -17,9 +17,10 @@ data TestCase a = String :~ a
|
||||
infixr 0 :~
|
||||
|
||||
testCases :: Outputable a => DynFlags -> String -> [TestCase a] -> TestTree
|
||||
testCases dflags name cases = testCase name $ mapM_ run cases
|
||||
testCases dflags name cases = testGroup name $ map run cases
|
||||
where
|
||||
run (expected :~ x) = expected @=? showPpr dflags x
|
||||
run (expected :~ x) =
|
||||
testCase (takeWhile (/='\n') expected) $ expected @=? showPpr dflags x
|
||||
|
||||
testTypes :: DynFlags -> String -> [TestCase HsType'] -> TestTree
|
||||
testTypes = testCases
|
||||
@ -30,13 +31,17 @@ testExprs = testCases
|
||||
testDecls :: DynFlags -> String -> [TestCase HsDecl'] -> TestTree
|
||||
testDecls = testCases
|
||||
|
||||
testPats :: DynFlags -> String -> [TestCase Pat'] -> TestTree
|
||||
testPats = testCases
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = runGhc (Just libdir) $ do
|
||||
dflags <- getDynFlags
|
||||
liftIO $ defaultMain $ testGroup "Tests"
|
||||
[typesTest dflags, exprsTest dflags, declsTest dflags]
|
||||
[typesTest dflags, exprsTest dflags, declsTest dflags, patsTest dflags]
|
||||
|
||||
typesTest, exprsTest, declsTest :: DynFlags -> TestTree
|
||||
typesTest, exprsTest, declsTest, patsTest :: DynFlags -> TestTree
|
||||
typesTest dflags = testGroup "Type"
|
||||
[ test "var"
|
||||
[ "A" :~ var "A"
|
||||
@ -49,6 +54,8 @@ typesTest dflags = testGroup "Type"
|
||||
[ "A x" :~ var "A" @@ var "x"
|
||||
, "(+) x" :~ var "+" @@ var "x"
|
||||
, "A (B x)" :~ var "A" @@ par (var "B" @@ var "x")
|
||||
, "A (B x)" :~ var "A" @@ par (var "B" @@ var "x")
|
||||
, "A ((B x))" :~ var "A" @@ par (par (var "B" @@ var "x"))
|
||||
, "A x (B y z)" :~ var "A" @@ var "x" @@ (var "B" @@ var "y" @@ var "z")
|
||||
, "A w (B x y) Z"
|
||||
:~ var "A" @@ var "w" @@ (var "B" @@ var "x" @@ var "y") @@ var "Z"
|
||||
@ -57,9 +64,11 @@ typesTest dflags = testGroup "Type"
|
||||
[ "x + y" :~ op (var "x") "+" (var "y")
|
||||
, "x `add` y" :~ op (var "x") "add" (var "y")
|
||||
, "x * (y + z)" :~ op (var "x") "*" (op (var "y") "+" (var "z"))
|
||||
, "(x * y) + z" :~ op (op (var "x") "*" (var "y")) "+" (var "z")
|
||||
, "x `mult` (y `add` z)" :~ op (var "x") "mult" (op (var "y") "add" (var "z"))
|
||||
, "A x * (B y + C z)" :~ op (var "A" @@ var "x") "*"
|
||||
(op (var "B" @@ var "y") "+" (var "C" @@ var "z"))
|
||||
, "(f . g) x" :~ op (var "f") "." (var "g") @@ var "x"
|
||||
]
|
||||
, test "function"
|
||||
[ "a -> b" :~ var "a" --> var "b"
|
||||
@ -95,7 +104,9 @@ exprsTest dflags = testGroup "Expr"
|
||||
[ "A x" :~ var "A" @@ var "x"
|
||||
, "(+) x" :~ var "+" @@ var "x"
|
||||
, "(Prelude.+) x" :~ var "Prelude.+" @@ var "x"
|
||||
, "A (B x)" :~ var "A" @@ (var "B" @@ var "x")
|
||||
, "A (B x)" :~ var "A" @@ par (var "B" @@ var "x")
|
||||
, "A ((B x))" :~ var "A" @@ par (par (var "B" @@ var "x"))
|
||||
, "A x (B y z)" :~ var "A" @@ var "x" @@ (var "B" @@ var "y" @@ var "z")
|
||||
, "A w (B x y) Z"
|
||||
:~ var "A" @@ var "w" @@ (var "B" @@ var "x" @@ var "y") @@ var "Z"
|
||||
@ -105,15 +116,23 @@ exprsTest dflags = testGroup "Expr"
|
||||
, "A ((-3) % 1)" :~ var "A" @@ frac (-3.0)
|
||||
, "A 'x'" :~ var "A" @@ char 'x'
|
||||
, "A \"xyz\"" :~ var "A" @@ string "xyz"
|
||||
, "(\\ x -> x) (\\ x -> x)" :~
|
||||
let f = lambda [var "x"] (var "x")
|
||||
in f @@ f
|
||||
]
|
||||
, test "op"
|
||||
[ "x + y" :~ op (var "x") "+" (var "y")
|
||||
, "x Prelude.+ y" :~ op (var "x") "Prelude.+" (var "y")
|
||||
, "x `add` y" :~ op (var "x") "add" (var "y")
|
||||
, "x * (y + z)" :~ op (var "x") "*" (op (var "y") "+" (var "z"))
|
||||
, "(x * y) + z" :~ op (op (var "x") "*" (var "y")) "+" (var "z")
|
||||
, "x `mult` (y `add` z)" :~ op (var "x") "mult" (op (var "y") "add" (var "z"))
|
||||
, "A x * (B y + C z)" :~ op (var "A" @@ var "x") "*"
|
||||
(op (var "B" @@ var "y") "+" (var "C" @@ var "z"))
|
||||
, "(f . g) x" :~ op (var "f") "." (var "g") @@ var "x"
|
||||
, "(\\ x -> x) . (\\ x -> x)" :~
|
||||
let f = lambda [var "x"] (var "x")
|
||||
in op f "." f
|
||||
]
|
||||
, test "period-op"
|
||||
[ "(Prelude..) x" :~ var "Prelude.." @@ var "x"
|
||||
@ -214,3 +233,44 @@ declsTest dflags = testGroup "Decls"
|
||||
]
|
||||
where
|
||||
test = testDecls dflags
|
||||
|
||||
patsTest dflags = testGroup "Pats"
|
||||
[ test "app"
|
||||
[ "A x y" :~ conP "A" [var "x", var "y"]
|
||||
, "(:) x y" :~ conP ":" [var "x", var "y"]
|
||||
, "(Prelude.:) x" :~ conP "Prelude.:" [var "x"]
|
||||
, "A (B x)" :~ conP "A" [conP "B" [var "x"]]
|
||||
, "A (B x)" :~ conP "A" [par $ conP "B" [var "x"]]
|
||||
, "A ((B x))" :~ conP "A" [par $ par $ conP "B" [var "x"]]
|
||||
, "A x (B y z)" :~ conP "A" [var "x", conP "B" [var "y", var "z"]]
|
||||
, "A w (B x y) Z"
|
||||
:~ conP "A" [var "w", conP "B" [var "x", var "y"], conP "Z" []]
|
||||
, "A 3" :~ conP "A" [int 3]
|
||||
, "A (-3)" :~ conP "A" [int (-3)]
|
||||
-- TODO(#33): this is incorrect:
|
||||
-- , "A (3 % 1)" :~ conP "A" [frac 3.0]
|
||||
-- , "A ((-3) % 1)" :~ conP "A" [frac (-3.0)]
|
||||
, "A 'x'" :~ conP "A" [char 'x']
|
||||
, "A \"xyz\"" :~ conP "A" [string "xyz"]
|
||||
]
|
||||
, test "asP"
|
||||
[ "x@B" :~ asP "x" $ conP "B" []
|
||||
, "x@(B y)" :~ asP "x" $ conP "B" [var "y"]
|
||||
, "x@_" :~ asP "x" wildP
|
||||
]
|
||||
, test "strictP"
|
||||
[ "!x" :~ strictP $ var "x"
|
||||
, "!B" :~ strictP $ conP "B" []
|
||||
, "!(B y)" :~ strictP $ conP "B" [var "y"]
|
||||
, "!_" :~ strictP wildP
|
||||
]
|
||||
, test "lazyP"
|
||||
[ "~x" :~ lazyP $ var "x"
|
||||
, "~B" :~ lazyP $ conP "B" []
|
||||
, "~(B y)" :~ lazyP $ conP "B" [var "y"]
|
||||
, "~_" :~ lazyP wildP
|
||||
]
|
||||
]
|
||||
where
|
||||
test = testPats dflags
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user