mirror of
https://github.com/google/ghc-source-gen.git
synced 2024-09-11 22:07:09 +03:00
Replace matchRhs/matchRhs with match/matchGRHSs. (#26)
Optimize names for the common case taking just an expression on the RHS. Also for `valBind` and `patBind`.
This commit is contained in:
parent
2cceb66969
commit
362eadc898
@ -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"
|
||||
|
@ -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 }
|
||||
|
||||
|
@ -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
|
||||
|
@ -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'
|
||||
|
@ -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
|
||||
|
@ -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"
|
||||
|
@ -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")
|
||||
]
|
||||
|
Loading…
Reference in New Issue
Block a user