google/ghc-source-gen
1
1
Fork 0
mirror of https://github.com/google/ghc-source-gen.git synced 2024-09-11 22:07:09 +03:00
Code Issues Projects Releases Wiki Activity

Replace matchRhs/matchRhs with match/matchGRHSs. (#26)

Browse Source 
Optimize names for the common case taking just an expression
on the RHS.

Also for `valBind` and `patBind`.
This commit is contained in:
Judah Jacobson 2019-08-17 22:21:24 -07:00 committed by GitHub
parent 2cceb66969
commit 362eadc898
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
7 changed files with 80 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
README.md
View File

@ -26,7 +26,7 @@ constModule :: HsModule'
constModule =
module' (Just "Const") (Just [var "const"]) []
[ typeSig "const" $ a --> b --> a
, funBind "const" $ matchRhs [wildP, x] x
, funBind "const" $ match [wildP, x] x
]
where
a = var "a"

74
src/GHC/SourceGen/Binds.hs
View File

@ -16,17 +16,17 @@ module GHC.SourceGen.Binds
, funBind
, funBinds
-- * Values
, valBindRhs
, valBind
, valBindGRHSs
-- ** Patterns
, HasPatBind
, patBindRhs
, patBind
, patBindGRHSs
-- * Matches
-- $rawMatch
, RawMatch
, match
, matchRhs
, matchGRHSs
-- * Right-hand sides
, RawGRHSs
, rhs
@ -78,18 +78,18 @@ typeSig n = typeSigs [n]
--
-- > f = x
-- > =====
-- > funBinds "f" [matchRhs [] "x"]
-- > funBinds "f" [match [] "x"]
--
-- > id x = x
-- > =====
-- > funBinds "id" [matchRhs [var "x"] (var "x")]
-- > funBinds "id" [match [var "x"] (var "x")]
--
-- > not True = False
-- > not False = True
-- > =====
-- > funBinds "not"
-- > [ matchRhs [conP "True" []] (var "False")
-- > , matchRhs [conP "False" []] (var "True")
-- > [ match [conP "True" []] (var "False")
-- > , match [conP "False" []] (var "True")
-- > ]
funBinds :: HasValBind t => OccNameStr -> [RawMatch] -> t
funBinds name matches = bindB $ withPlaceHolder
@ -104,11 +104,11 @@ funBinds name matches = bindB $ withPlaceHolder
--
-- > f = x
-- > =====
-- > funBind "f" (matchRhs [] "x")
-- > funBind "f" (match [] "x")
--
-- > id x = x
-- > =====
-- > funBind "id" $ matchRhs [var "x"] (var "x")
-- > funBind "id" $ match [var "x"] (var "x")
--
funBind :: HasValBind t => OccNameStr -> RawMatch -> t
funBind name m = funBinds name [m]
@ -117,21 +117,17 @@ funBind name m = funBinds name [m]
--
-- The resulting syntax is the same as a function with no arguments.
--
-- > x = y
-- > =====
-- > valBind "x" $ rhs $ var "y"
--
-- > x
-- > | test = 1
-- > | otherwise = 2
-- > =====
-- > valBind "x"
-- > valBindGRHSs "x"
-- > $ guardedRhs
-- > [ var "test" `guard` int 1
-- > , var "otherwise" `guard` int 2
-- > ]
valBind :: HasValBind t => OccNameStr -> RawGRHSs -> t
valBind name = funBind name . match []
-- > [ var "test" `guard` int 1
-- > , var "otherwise" `guard` int 2
-- > ]
valBindGRHSs :: HasValBind t => OccNameStr -> RawGRHSs -> t
valBindGRHSs name = funBind name . matchGRHSs []
-- | Defines a value without any guards.
--
@ -139,27 +135,23 @@ valBind name = funBind name . match []
--
-- > x = y
-- > =====
-- > valBindRhs "x" $ var "y"
valBindRhs :: HasValBind t => OccNameStr -> HsExpr' -> t
valBindRhs name = valBind name . rhs
-- > valBind "x" $ var "y"
valBind :: HasValBind t => OccNameStr -> HsExpr' -> t
valBind name = valBindGRHSs name . rhs
-- | Defines a pattern binding consisting of multiple guards.
--
-- > (x, y) = e
-- > =====
-- > patBind (tuple [var "x", var "y"]) $ rhs e
--
-- > (x, y)
-- > | test = (1, 2)
-- > | otherwise = (2, 3)
-- > =====
-- > patBind (tuple [var "x", var "y"])
-- > patBindGrhs (tuple [var "x", var "y"])
-- > $ guardedRhs
-- > [ var "test" `guard` tuple [int 1, int 2]
-- > , var "otherwise" `guard` [int 2, int 3]
-- > ]
patBind :: HasPatBind t => Pat' -> RawGRHSs -> t
patBind p g =
patBindGRHSs :: HasPatBind t => Pat' -> RawGRHSs -> t
patBindGRHSs p g =
bindB
$ withPlaceHolder
(withPlaceHolder
@ -170,9 +162,9 @@ patBind p g =
--
-- > (x, y) = e
-- > =====
-- > patBindRhs (tuple [var "x", var "y"]) e
patBindRhs :: HasPatBind t => Pat' -> HsExpr' -> t
patBindRhs p = patBind p . rhs
-- > patBind (tuple [var "x", var "y"]) e
patBind :: HasPatBind t => Pat' -> HsExpr' -> t
patBind p = patBindGRHSs p . rhs
{- $rawMatch
@ -186,8 +178,8 @@ A function definition is made up of one or more 'RawMatch' terms. Each
We could using a list of two 'RawMatch'es:
> funBinds "not"
> [ matchRhs [conP "True" []] (var "False")
> , matchRhs [conP "False" [] (var "True")
> [ match [conP "True" []] (var "False")
> , match [conP "False" [] (var "True")
> ]
A match may consist of one or more guarded expressions. For example, to
@ -200,19 +192,19 @@ define the function as:
We would say:
> funBind "not"
> $ match [var "x"] $ guardedRhs
> $ matchGRHSs [var "x"] $ guardedRhs
> [ guard (var "x") (var "False")
> , guard (var "otherwise") (var "True")
> ]
-}
-- | A function match consisting of multiple guards.
match :: [Pat'] -> RawGRHSs -> RawMatch
match = RawMatch
matchGRHSs :: [Pat'] -> RawGRHSs -> RawMatch
matchGRHSs = RawMatch
-- | A function match with a single case.
matchRhs :: [Pat'] -> HsExpr' -> RawMatch
matchRhs ps = match ps . rhs
match :: [Pat'] -> HsExpr' -> RawMatch
match ps = matchGRHSs ps . rhs
-- | Adds a "where" clause to an existing 'RawGRHSs'.
--
@ -220,9 +212,9 @@ matchRhs ps = match ps . rhs
-- > where y = x
-- > =====
-- > funBind "x"
-- > $ match [var "x"]
-- > $ matchGRHSs [var "x"]
-- > $ rhs (var "y")
-- > `where` [valueRhs (var "y") $ var "x']
-- > `where` [valBind (var "y") $ var "x']
where' :: RawGRHSs -> [RawValBind] -> RawGRHSs
where' r vbs = r { rawGRHSWhere = rawGRHSWhere r ++ vbs }

2
src/GHC/SourceGen/Binds/Internal.hs
View File

@ -115,7 +115,7 @@ type GuardedExpr = GRHS' (Located HsExpr')
-- 'GHC.SourceGen.Binds.funBind' or 'GHC.SourceGen.Binds.funBinds'.
--
-- To define a value, use
-- 'GHC.SourceGen.Binds.valBind' or 'GHC.SourceGen.Binds.valBindRhs'.
-- 'GHC.SourceGen.Binds.valBind' or 'GHC.SourceGen.Binds.valBindGuarded'.
class HasValBind t where
sigB :: Sig' -> t
bindB :: HsBind' -> t

6
src/GHC/SourceGen/Decl.hs
View File

@ -127,7 +127,7 @@ funDep = ClassFunDep
-- > [ typeSig "divMod" $ a --> a --> tuple [a, a]
-- > , typeSig "div" $ a --> a --> a
-- > , funBind "div"
-- > $ matchRhs [var "x", var "y"]
-- > $ match [var "x", var "y"]
-- > $ var "fst" @@ (var "divMod" @@ var "x" @@ var "y")
-- > ]
class'
@ -181,8 +181,8 @@ instance HasValBind RawInstDecl where
-- > instance' (var "Show" @@ var "Bool")
-- > [ typeSig "show" $ var "Bool" --> var "String"
-- > , funBinds "show"
-- > [ matchRhs [var "True"] $ string "True"
-- > , matchRhs [var "False"] $ string "False"
-- > [ match [var "True"] $ string "True"
-- > , match [var "False"] $ string "False"
-- > ]
-- > ]
instance' :: HsType' -> [RawInstDecl] -> HsDecl'

2
src/GHC/SourceGen/Expr.hs
View File

@ -56,7 +56,7 @@ case' e matches = noExt HsCase (builtLoc e)
$ matchGroup CaseAlt matches
lambda :: [Pat'] -> HsExpr' -> HsExpr'
lambda ps e = noExt HsLam $ matchGroup LambdaExpr [matchRhs ps e]
lambda ps e = noExt HsLam $ matchGroup LambdaExpr [match ps e]
lambdaCase :: [RawMatch] -> HsExpr'
lambdaCase = noExt HsLamCase . matchGroup CaseAlt

62
tests/pprint_examples.hs
View File

@ -30,7 +30,7 @@ test1 = pprint $ tuple
, char 'g'
, let' [ typeSig "result" $ var "A" @@ var "B"
, funBind "result"
$ matchRhs [var "x", wildP]
$ match [var "x", wildP]
$ var "foo" @@ char 'c'
]
(var "result")
@ -40,37 +40,37 @@ test2 :: IO ()
test2 = pprint $ module' (Just "Foo") (Just [var "efg"]) []
[ typeSigs ["efg", "h"] $ tuple [var "A", var "B"]
, funBind "efg"
$ match []
$ matchGRHSs []
$ rhs (char 'a')
`where'` [ typeSig "q" $ var "Q"
, funBind "q" $ match []
, funBind "q" $ matchGRHSs []
$ guardedRhs [var "True" `guard` char 'q']
]
, funBind "f"
$ match [var "x", var "y"]
$ matchGRHSs [var "x", var "y"]
$ rhs
(case' (var "y")
[matchRhs [wildP] $ var "x"])
`where'` [funBind "q" $ matchRhs [] $ char 't']
[match [wildP] $ var "x"])
`where'` [funBind "q" $ match [] $ char 't']
]
test3 :: IO ()
test3 = pprint $ module' Nothing Nothing []
[ funBind "lambdas" $ matchRhs [] $ lambda [var "y"]
$ lambdaCase [matchRhs [var "z"] (char 'a')]
[ funBind "lambdas" $ match [] $ lambda [var "y"]
$ lambdaCase [match [var "z"] (char 'a')]
, funBinds "ifs"
[ matchRhs [var "x"] $ if' (var "b") (var "t") (var "f")
, matchRhs [var "y"] $ multiIf [guard (var "False") $ char 'f'
[ match [var "x"] $ if' (var "b") (var "t") (var "f")
, match [var "y"] $ multiIf [guard (var "False") $ char 'f'
, guard (var "True") $ char 't'
]
, matchRhs [var "z"] $ multiIf
, match [var "z"] $ multiIf
[ guard (var "f" @@ var "x") $ string "f"
, guard (var "g" @@ var "x") $ string "g"
, guard (var "otherwise") $ string "h"
]
]
, funBind "do'"
$ matchRhs [] (do' [ var "x" <-- var "act"
$ match [] (do' [ var "x" <-- var "act"
, stmt $ var "return" @@ var "x"
])
, typeSig "types"
@ -81,34 +81,34 @@ test3 = pprint $ module' Nothing Nothing []
(forall' [var "x", var "y"]
$ var "y")
, funBind "swap"
$ matchRhs [tuple [var "x", var "y"]]
$ match [tuple [var "x", var "y"]]
$ tuple [var "y", var "x"]
, funBind "char" $ matchRhs [char 'a'] (char 'b')
, funBind "string" $ matchRhs [string "abc"] (string "def")
, funBind "char" $ match [char 'a'] (char 'b')
, funBind "string" $ match [string "abc"] (string "def")
, funBind "as"
$ matchRhs [asP "x" (tuple [var "y", var "z"])]
$ match [asP "x" (tuple [var "y", var "z"])]
(var "x")
, funBind "con"
$ matchRhs [conP "A" [var "b", conP "C" [var "d"]]]
$ match [conP "A" [var "b", conP "C" [var "d"]]]
$ tuple [var "b", var "d"]
, funBind "ops"
$ matchRhs [var "x", var "y"]
$ match [var "x", var "y"]
$ op (var "x") "+" (var "y")
, funBinds "ops'"
[ matchRhs [] (op (int 1) "*"
[ match [] (op (int 1) "*"
(op (int 2) "+" (int 3)))
, matchRhs [] (op (var "A" @@ var "x") "*"
, match [] (op (var "A" @@ var "x") "*"
(op (var "B" @@ var "y") "+"
(var "C" @@ var "z")))
, matchRhs [] (op (var "A" @@ var "x") "mult"
, match [] (op (var "A" @@ var "x") "mult"
(op (var "B" @@ var "y") "+"
(var "C" @@ var "z")))
]
, funBinds "cons'"
[ matchRhs [] (var "X" @@ int 1 @@
[ match [] (var "X" @@ int 1 @@
(var "Y" @@ int 2 @@ int 3)
@@ var "Z")
, matchRhs [] (var "f" @@ par (var "g" @@ var "x"))
, match [] (var "f" @@ par (var "g" @@ var "x"))
]
, typeSig "f" $ var "X" @@ var "a" @@
(var "Y" @@ var "b" @@ var "c")
@ -118,7 +118,7 @@ test3 = pprint $ module' Nothing Nothing []
(var "C" @@ var "z"))
, class' [var "A" @@ var "a"] "B" ["b", "b'"]
[ typeSig "f" $ var "b" --> var "b'"
, funBind "f" $ matchRhs [] $ var "id"
, funBind "f" $ match [] $ var "id"
]
, class' [] "F" ["a", "b", "c"]
[ funDep ["a", "b"] ["c"]
@ -139,7 +139,7 @@ test3 = pprint $ module' Nothing Nothing []
[deriving' [var "X", var "Y"]]
, instance' (var "A" @@ var "b" @@ var "c")
[ typeSig "f" $ var "b" --> var "c"
, funBind "f" $ matchRhs [] $ var "undefined"
, funBind "f" $ match [] $ var "undefined"
]
, let a = var "a"
in class'
@ -149,14 +149,14 @@ test3 = pprint $ module' Nothing Nothing []
[ typeSig "divMod" $ a --> a --> tuple [a, a]
, typeSig "div" $ a --> a --> a
, funBind "div"
$ matchRhs [var "x", var "y"]
$ match [var "x", var "y"]
$ var "fst" @@ (var "divMod" @@ var "x" @@ var "y")
]
, instance' (var "Show" @@ var "Bool")
[ typeSig "show" $ var "Bool" --> var "String"
, funBinds "show"
[ matchRhs [var "True"] $ string "True"
, matchRhs [var "False"] $ string "False"
[ match [var "True"] $ string "True"
, match [var "False"] $ string "False"
]
]
, data' "X" ["b"]
@ -191,12 +191,12 @@ test3 = pprint $ module' Nothing Nothing []
]
[]
, funBind "strictness"
$ matchRhs
$ match
[strictP (conP "A" [var "b"]),
lazyP (conP "A" [var "b"])
] (char 'x')
, typeSig "unit" $ unit --> unit
, funBind "unit" $ matchRhs [unit] unit
, funBind "unit" $ match [unit] unit
]
test4 :: IO ()
@ -219,7 +219,7 @@ test5 = pprint $ module' (Just "M") (Just exports) imports []
constModule :: HsModule'
constModule = module' (Just "Const") (Just [var "const"]) []
[ typeSig "const" $ a --> b --> a
, funBind "const" $ matchRhs [wildP, x] x
, funBind "const" $ match [wildP, x] x
]
where
a = var "a"

20
tests/pprint_test.hs
View File

@ -155,17 +155,17 @@ exprsTest dflags = testGroup "Expr"
declsTest dflags = testGroup "Decls"
[ test "patBind"
[ "x = x" :~ patBind (var "x") (rhs $ var "x")
[ "x = x" :~ patBind (var "x") (var "x")
, "(x, y) = (y, x)" :~ patBind (tuple [var "x", var "y"])
(rhs $ tuple [var "y", var "x"])
(tuple [var "y", var "x"])
, "(x, y)\n | test = (1, 2)\n | otherwise = (2, 3)" :~
patBind (tuple [var "x", var "y"])
patBindGRHSs (tuple [var "x", var "y"])
$ guardedRhs
[ var "test" `guard` tuple [int 1, int 2]
, var "otherwise" `guard` tuple [int 2, int 3]
]
, "z | Just y <- x, y = ()" :~
patBind (var "z")
patBindGRHSs (var "z")
$ guardedRhs
[guards
[ conP "Just" [var "y"] <-- var "x"
@ -175,10 +175,10 @@ declsTest dflags = testGroup "Decls"
]
]
, test "valBind"
[ "x = y" :~ valBind "x" $ rhs $ var "y"
, "x = y" :~ valBindRhs "x" $ var "y"
[ "x = y" :~ valBindGRHSs "x" $ rhs $ var "y"
, "x = y" :~ valBind "x" $ var "y"
, "x | test = 1\n | otherwise = 2" :~
valBind "x"
valBindGRHSs "x"
$ guardedRhs
[ var "test" `guard` int 1
, var "otherwise" `guard` int 2
@ -187,12 +187,12 @@ declsTest dflags = testGroup "Decls"
, test "funBind"
[ "not True = False\nnot False = True" :~
funBinds "not"
[ matchRhs [var "True"] (var "False")
, matchRhs [var "False"] (var "True")
[ match [var "True"] (var "False")
, match [var "False"] (var "True")
]
, "not x\n | x = False\n | otherwise = True" :~
funBind "not"
$ match [var "x"] $ guardedRhs
$ matchGRHSs [var "x"] $ guardedRhs
[ guard (var "x") (var "False")
, guard (var "otherwise") (var "True")
]