mirror of
https://github.com/google/ghc-source-gen.git
synced 2024-09-11 22:07:09 +03:00
Use the BVar class for patterns and type variable bindings. (#46)
Also make data/newtype declaration type parameters be OccNameStr.
This commit is contained in:
Judah Jacobson
GitHub
parent
dd074652a6
commit
316e9c28bc
@ -108,7 +108,7 @@ funBinds name matches = bindB $ withPlaceHolder
|
||||
--
|
||||
-- > id x = x
|
||||
-- > =====
|
||||
-- > funBind "id" $ match [var "x"] (var "x")
|
||||
-- > funBind "id" $ match [bvar "x"] (var "x")
|
||||
--
|
||||
funBind :: HasValBind t => OccNameStr -> RawMatch -> t
|
||||
funBind name m = funBinds name [m]
|
||||
@ -145,7 +145,7 @@ valBind name = valBindGRHSs name . rhs
|
||||
-- > | test = (1, 2)
|
||||
-- > | otherwise = (2, 3)
|
||||
-- > =====
|
||||
-- > patBindGrhs (tuple [var "x", var "y"])
|
||||
-- > patBindGrhs (tuple [bvar "x", bvar "y"])
|
||||
-- > $ guardedRhs
|
||||
-- > [ var "test" `guard` tuple [int 1, int 2]
|
||||
-- > , var "otherwise" `guard` [int 2, int 3]
|
||||
@ -162,7 +162,7 @@ patBindGRHSs p g =
|
||||
--
|
||||
-- > (x, y) = e
|
||||
-- > =====
|
||||
-- > patBind (tuple [var "x", var "y"]) e
|
||||
-- > patBind (tuple [bvar "x", bvar "y"]) e
|
||||
patBind :: HasPatBind t => Pat' -> HsExpr' -> t
|
||||
patBind p = patBindGRHSs p . rhs
|
||||
|
||||
@ -192,7 +192,7 @@ define the function as:
|
||||
We would say:
|
||||
|
||||
> funBind "not"
|
||||
> $ matchGRHSs [var "x"] $ guardedRhs
|
||||
> $ matchGRHSs [bvar "x"] $ guardedRhs
|
||||
> [ guard (var "x") (var "False")
|
||||
> , guard (var "otherwise") (var "True")
|
||||
> ]
|
||||
@ -212,9 +212,9 @@ match ps = matchGRHSs ps . rhs
|
||||
-- > where y = x
|
||||
-- > =====
|
||||
-- > funBind "x"
|
||||
-- > $ matchGRHSs [var "x"]
|
||||
-- > $ matchGRHSs [bvar "x"]
|
||||
-- > $ rhs (var "y")
|
||||
-- > `where` [valBind (var "y") $ var "x']
|
||||
-- > `where` [valBind "y" $ var "x']
|
||||
where' :: RawGRHSs -> [RawValBind] -> RawGRHSs
|
||||
where' r vbs = r { rawGRHSWhere = rawGRHSWhere r ++ vbs }
|
||||
|
||||
@ -246,7 +246,7 @@ guard s = guards [stmt s]
|
||||
--
|
||||
-- > | Just y <- x, y = ()
|
||||
-- > =====
|
||||
-- > guards [conP "Just" (var "x") <-- var "y", var "x"] unit
|
||||
-- > guards [conP "Just" (bvar "x") <-- var "y", bvar "x"] unit
|
||||
guards :: [Stmt'] -> HsExpr' -> GuardedExpr
|
||||
guards stmts e = noExt GRHS (map builtLoc stmts) (builtLoc e)
|
||||
|
||||
@ -263,7 +263,7 @@ stmt e =
|
||||
--
|
||||
-- > x <- act
|
||||
-- > =====
|
||||
-- > var "x" <-- var "act"
|
||||
-- > bvar "x" <-- var "act"
|
||||
(<--) :: Pat' -> HsExpr' -> Stmt'
|
||||
p <-- e = withPlaceHolder $ noExt BindStmt (builtPat p) (builtLoc e) noSyntaxExpr noSyntaxExpr
|
||||
infixl 1 <--
|
||||
|
||||
@ -132,13 +132,13 @@ funDep = ClassFunDep
|
||||
-- > [ typeSig "divMod" $ a --> a --> tuple [a, a]
|
||||
-- > , typeSig "div" $ a --> a --> a
|
||||
-- > , funBind "div"
|
||||
-- > $ match [var "x", var "y"]
|
||||
-- > $ match [bvar "x", bvar "y"]
|
||||
-- > $ var "fst" @@ (var "divMod" @@ var "x" @@ var "y")
|
||||
-- > ]
|
||||
class'
|
||||
:: [HsType'] -- ^ Context
|
||||
-> OccNameStr -- ^ Class name
|
||||
-> [RdrNameStr] -- ^ Type parameters
|
||||
-> [OccNameStr] -- ^ Type parameters
|
||||
-> [ClassDecl] -- ^ Class declarations
|
||||
-> HsDecl'
|
||||
class' context name vars decls
|
||||
@ -186,8 +186,8 @@ instance HasValBind RawInstDecl where
|
||||
-- > instance' (var "Show" @@ var "Bool")
|
||||
-- > [ typeSig "show" $ var "Bool" --> var "String"
|
||||
-- > , funBinds "show"
|
||||
-- > [ match [var "True"] $ string "True"
|
||||
-- > , match [var "False"] $ string "False"
|
||||
-- > [ match [bvar "True"] $ string "True"
|
||||
-- > , match [bvar "False"] $ string "False"
|
||||
-- > ]
|
||||
-- > ]
|
||||
instance' :: HsType' -> [RawInstDecl] -> HsDecl'
|
||||
@ -247,7 +247,7 @@ tyFamInst name params ty = tyFamInstD
|
||||
-- > type A a b = B b a
|
||||
-- > =====
|
||||
-- > type' "A" ["a", "b"] $ var "B" @@ var "b" @@ var "a"
|
||||
type' :: OccNameStr -> [RdrNameStr] -> HsType' -> HsDecl'
|
||||
type' :: OccNameStr -> [OccNameStr] -> HsType' -> HsDecl'
|
||||
type' name vars t =
|
||||
noExt TyClD $ withPlaceHolder $ noExt SynDecl (typeRdrName $ unqual name)
|
||||
(mkQTyVars vars)
|
||||
@ -257,7 +257,7 @@ type' name vars t =
|
||||
newOrDataType
|
||||
:: NewOrData
|
||||
-> OccNameStr
|
||||
-> [RdrNameStr]
|
||||
-> [OccNameStr]
|
||||
-> [ConDecl']
|
||||
-> [HsDerivingClause']
|
||||
-> HsDecl'
|
||||
@ -279,7 +279,7 @@ newOrDataType newOrData name vars conDecls derivs
|
||||
-- > newtype' "Const" ["a", "b"]
|
||||
-- > (conDecl "Const" [var "a"])
|
||||
-- > [var "Show"]
|
||||
newtype' :: OccNameStr -> [RdrNameStr] -> ConDecl' -> [HsDerivingClause'] -> HsDecl'
|
||||
newtype' :: OccNameStr -> [OccNameStr] -> ConDecl' -> [HsDerivingClause'] -> HsDecl'
|
||||
newtype' name vars conD = newOrDataType NewType name vars [conD]
|
||||
|
||||
-- | A data declaration.
|
||||
@ -292,7 +292,7 @@ newtype' name vars conD = newOrDataType NewType name vars [conD]
|
||||
-- > , conDecl "Right" [var "b"]
|
||||
-- > ]
|
||||
-- > [var "Show"]
|
||||
data' :: OccNameStr -> [RdrNameStr] -> [ConDecl'] -> [HsDerivingClause'] -> HsDecl'
|
||||
data' :: OccNameStr -> [OccNameStr] -> [ConDecl'] -> [HsDerivingClause'] -> HsDecl'
|
||||
data' = newOrDataType DataType
|
||||
|
||||
-- | Declares a Haskell-98-style prefix constructor for a data or type
|
||||
|
||||
@ -86,7 +86,7 @@ multiIf = noExtOrPlaceHolder HsMultiIf . map builtLoc
|
||||
-- > x <- act
|
||||
-- > return x
|
||||
-- > =====
|
||||
-- > do' [var "x" <-- var "act", stmt $ var "return" @@ var "x"]
|
||||
-- > do' [bvar "x" <-- var "act", stmt $ var "return" @@ var "x"]
|
||||
do' :: [Stmt'] -> HsExpr'
|
||||
do' = withPlaceHolder . noExt HsDo DoExpr
|
||||
. builtLoc . map (builtLoc . parenthesizeIfLet)
|
||||
|
||||
@ -15,6 +15,7 @@ module GHC.SourceGen.Overloaded
|
||||
, unboxedTuple
|
||||
, HasList(..)
|
||||
, Var(..)
|
||||
, BVar(..)
|
||||
) where
|
||||
|
||||
import BasicTypes (Boxity(..))
|
||||
@ -34,7 +35,7 @@ import HsSyn
|
||||
, HsTupleSort(..)
|
||||
)
|
||||
import DataCon (dataConName)
|
||||
import RdrName (RdrName, nameRdrName)
|
||||
import RdrName (RdrName(..), nameRdrName)
|
||||
import SrcLoc (Located)
|
||||
import TysWiredIn (consDataCon_RDR, nilDataCon, unitDataCon)
|
||||
|
||||
@ -209,26 +210,43 @@ instance HasList Pat' where
|
||||
nil = noExt VarPat nilDataConName
|
||||
cons = noExt VarPat $ builtLoc $ consDataCon_RDR
|
||||
|
||||
-- | Terms that can contain references to locally-bound variables.
|
||||
--
|
||||
-- Depending on the context, @'bvar' \"a\"@ could refer to either a
|
||||
-- pattern variable or a type variable.
|
||||
class BVar a where
|
||||
bvar :: OccNameStr -> a
|
||||
|
||||
-- | Terms that can contain references to named things. They may be actual variables,
|
||||
-- functions, or constructors. For example, @'var' \"a\"@ and @'var' \"A\"@
|
||||
-- are equally valid.
|
||||
-- Depending on the context, the former could refer to either a function,
|
||||
-- value, type variable, or pattern; and the latter could refer to either a type
|
||||
-- constructor or a data constructor,
|
||||
class Var a where
|
||||
class BVar a => Var a where
|
||||
var :: RdrNameStr -> a
|
||||
|
||||
instance Var Pat' where
|
||||
var = noExt VarPat . valueRdrName
|
||||
instance BVar Pat' where
|
||||
bvar = noExt VarPat . valueRdrName . UnqualStr
|
||||
|
||||
instance Var HsExpr' where
|
||||
var = noExt HsVar . valueRdrName
|
||||
|
||||
instance BVar HsExpr' where
|
||||
bvar = var . UnqualStr
|
||||
|
||||
instance Var HsType' where
|
||||
var = noExt HsTyVar notPromoted . typeRdrName
|
||||
|
||||
instance Var HsTyVarBndr' where
|
||||
var = noExt UserTyVar . typeRdrName
|
||||
instance BVar HsType' where
|
||||
bvar = var . UnqualStr
|
||||
|
||||
instance BVar HsTyVarBndr' where
|
||||
bvar = noExt UserTyVar . typeRdrName . UnqualStr
|
||||
|
||||
instance Var IE' where
|
||||
var n = noExt IEVar $ builtLoc $ IEName $ exportRdrName n
|
||||
|
||||
instance BVar IE' where
|
||||
bvar = var . UnqualStr
|
||||
|
||||
|
||||
@ -41,7 +41,7 @@ v `asP` p = noExt AsPat (valueRdrName v) $ builtPat $ parenthesize p
|
||||
--
|
||||
-- > A b c
|
||||
-- > =====
|
||||
-- > conP "A" [var "b", var "c"]
|
||||
-- > conP "A" [bvar "b", bvar "c"]
|
||||
conP :: RdrNameStr -> [Pat'] -> Pat'
|
||||
conP c xs = ConPatIn (valueRdrName c) $ PrefixCon
|
||||
$ map (builtPat . parenthesize) xs
|
||||
@ -64,7 +64,7 @@ recordConP c fs
|
||||
--
|
||||
-- > !x
|
||||
-- > =====
|
||||
-- > strictP (var x)
|
||||
-- > strictP (bvar x)
|
||||
strictP :: Pat' -> Pat'
|
||||
strictP = noExt BangPat . builtPat . parenthesize
|
||||
|
||||
@ -72,7 +72,7 @@ strictP = noExt BangPat . builtPat . parenthesize
|
||||
--
|
||||
-- > ~(A x)
|
||||
-- > =====
|
||||
-- > lazyP (conP "A" [var x])
|
||||
-- > lazyP (conP "A" [bvar x])
|
||||
lazyP :: Pat' -> Pat'
|
||||
lazyP = noExt LazyPat . builtPat . parenthesize
|
||||
|
||||
@ -80,7 +80,7 @@ lazyP = noExt LazyPat . builtPat . parenthesize
|
||||
--
|
||||
-- > x :: y
|
||||
-- > =====
|
||||
-- > sigPat (var "x") (var "y")
|
||||
-- > sigPat (bvar "x") (var "y")
|
||||
sigP :: Pat' -> HsType' -> Pat'
|
||||
#if MIN_VERSION_ghc(8,8,0)
|
||||
sigP p t = noExt SigPat p (sigWcType t)
|
||||
|
||||
@ -137,7 +137,7 @@ type HsType' = HsType RdrName
|
||||
--
|
||||
-- Instances:
|
||||
--
|
||||
-- * 'GHC.SourceGen.Overloaded.Var'
|
||||
-- * 'GHC.SourceGen.Overloaded.BVar'
|
||||
-- * 'GHC.SourceGen.Overloaded.Par'
|
||||
-- * 'GHC.SourceGen.Overloaded.HasTuple'
|
||||
-- * 'GHC.SourceGen.Overloaded.HasList'
|
||||
@ -152,6 +152,7 @@ type Pat' = Pat RdrName
|
||||
--
|
||||
-- Instances:
|
||||
--
|
||||
-- * 'GHC.SourceGen.Overloaded.BVar'
|
||||
-- * 'GHC.SourceGen.Overloaded.Var'
|
||||
-- * 'GHC.SourceGen.Overloaded.Par'
|
||||
-- * 'GHC.SourceGen.Overloaded.App'
|
||||
@ -180,6 +181,7 @@ type HsDecl' = HsDecl RdrName
|
||||
--
|
||||
-- Instances:
|
||||
--
|
||||
-- * 'GHC.SourceGen.Overloaded.BVar'
|
||||
-- * 'GHC.SourceGen.Overloaded.Var'
|
||||
#if MIN_VERSION_ghc(8,4,0)
|
||||
type IE' = IE GhcPs
|
||||
@ -192,7 +194,7 @@ type IE' = IE RdrName
|
||||
--
|
||||
-- Instances:
|
||||
--
|
||||
-- * 'GHC.SourceGen.Overloaded.Var'
|
||||
-- * 'GHC.SourceGen.Overloaded.BVar'
|
||||
#if MIN_VERSION_ghc(8,4,0)
|
||||
type HsTyVarBndr' = HsTyVarBndr GhcPs
|
||||
#else
|
||||
|
||||
@ -52,6 +52,11 @@ a --> b = noExt HsFunTy (parenthesizeTypeForFun $ builtLoc a) (builtLoc b)
|
||||
|
||||
infixr 0 -->
|
||||
|
||||
-- | A type variable binding.
|
||||
--
|
||||
-- > forall a . T a
|
||||
-- > =====
|
||||
-- > forall' [bvar "a"] $ var "T" @@ var "a"
|
||||
forall' :: [HsTyVarBndr'] -> HsType' -> HsType'
|
||||
forall' ts = noExt HsForAllTy (map builtLoc ts) . builtLoc
|
||||
|
||||
|
||||
@ -13,10 +13,10 @@ import SrcLoc (Located, unLoc)
|
||||
import GHC.SourceGen.Syntax.Internal
|
||||
import GHC.SourceGen.Name.Internal
|
||||
|
||||
mkQTyVars :: [RdrNameStr] -> LHsQTyVars'
|
||||
mkQTyVars :: [OccNameStr] -> LHsQTyVars'
|
||||
mkQTyVars vars = withPlaceHolder
|
||||
$ noExt (withPlaceHolder HsQTvs)
|
||||
$ map (builtLoc . noExt UserTyVar . typeRdrName)
|
||||
$ map (builtLoc . noExt UserTyVar . typeRdrName . UnqualStr)
|
||||
vars
|
||||
|
||||
sigType :: HsType' -> LHsSigType'
|
||||
|
||||
@ -30,7 +30,7 @@ test1 = pprint $ tuple
|
||||
, char 'g'
|
||||
, let' [ typeSig "result" $ var "A" @@ var "B"
|
||||
, funBind "result"
|
||||
$ match [var "x", wildP]
|
||||
$ match [bvar "x", wildP]
|
||||
$ var "foo" @@ char 'c'
|
||||
]
|
||||
(var "result")
|
||||
@ -47,7 +47,7 @@ test2 = pprint $ module' (Just "Foo") (Just [var "efg"]) []
|
||||
$ guardedRhs [var "True" `guard` char 'q']
|
||||
]
|
||||
, funBind "f"
|
||||
$ matchGRHSs [var "x", var "y"]
|
||||
$ matchGRHSs [bvar "x", bvar "y"]
|
||||
$ rhs
|
||||
(case' (var "y")
|
||||
[match [wildP] $ var "x"])
|
||||
@ -56,43 +56,43 @@ test2 = pprint $ module' (Just "Foo") (Just [var "efg"]) []
|
||||
|
||||
test3 :: IO ()
|
||||
test3 = pprint $ module' Nothing Nothing []
|
||||
[ funBind "lambdas" $ match [] $ lambda [var "y"]
|
||||
$ lambdaCase [match [var "z"] (char 'a')]
|
||||
[ funBind "lambdas" $ match [] $ lambda [bvar "y"]
|
||||
$ lambdaCase [match [bvar "z"] (char 'a')]
|
||||
, funBinds "ifs"
|
||||
[ match [var "x"] $ if' (var "b") (var "t") (var "f")
|
||||
, match [var "y"] $ multiIf [guard (var "False") $ char 'f'
|
||||
[ match [bvar "x"] $ if' (var "b") (var "t") (var "f")
|
||||
, match [bvar "y"] $ multiIf [guard (var "False") $ char 'f'
|
||||
, guard (var "True") $ char 't'
|
||||
]
|
||||
, match [var "z"] $ multiIf
|
||||
, match [bvar "z"] $ multiIf
|
||||
[ guard (var "f" @@ var "x") $ string "f"
|
||||
, guard (var "g" @@ var "x") $ string "g"
|
||||
, guard (var "otherwise") $ string "h"
|
||||
]
|
||||
]
|
||||
, funBind "do'"
|
||||
$ match [] (do' [ var "x" <-- var "act"
|
||||
$ match [] (do' [ bvar "x" <-- var "act"
|
||||
, stmt $ var "return" @@ var "x"
|
||||
])
|
||||
, typeSig "types"
|
||||
$ forall' [var "x", var "y"]
|
||||
$ forall' [bvar "x", bvar "y"]
|
||||
$ [var "Show" @@ var "x"] ==> var "y"
|
||||
, typeSig "types'"
|
||||
$ [var "Show" @@ var "x"] ==>
|
||||
(forall' [var "x", var "y"]
|
||||
(forall' [bvar "x", bvar "y"]
|
||||
$ var "y")
|
||||
, funBind "swap"
|
||||
$ match [tuple [var "x", var "y"]]
|
||||
$ match [tuple [bvar "x", bvar "y"]]
|
||||
$ tuple [var "y", var "x"]
|
||||
, funBind "char" $ match [char 'a'] (char 'b')
|
||||
, funBind "string" $ match [string "abc"] (string "def")
|
||||
, funBind "as"
|
||||
$ match [asP "x" (tuple [var "y", var "z"])]
|
||||
$ match [asP "x" (tuple [bvar "y", bvar "z"])]
|
||||
(var "x")
|
||||
, funBind "con"
|
||||
$ match [conP "A" [var "b", conP "C" [var "d"]]]
|
||||
$ match [conP "A" [bvar "b", conP "C" [bvar "d"]]]
|
||||
$ tuple [var "b", var "d"]
|
||||
, funBind "ops"
|
||||
$ match [var "x", var "y"]
|
||||
$ match [bvar "x", bvar "y"]
|
||||
$ op (var "x") "+" (var "y")
|
||||
, funBinds "ops'"
|
||||
[ match [] (op (int 1) "*"
|
||||
@ -149,14 +149,14 @@ test3 = pprint $ module' Nothing Nothing []
|
||||
[ typeSig "divMod" $ a --> a --> tuple [a, a]
|
||||
, typeSig "div" $ a --> a --> a
|
||||
, funBind "div"
|
||||
$ match [var "x", var "y"]
|
||||
$ match [bvar "x", bvar "y"]
|
||||
$ var "fst" @@ (var "divMod" @@ var "x" @@ var "y")
|
||||
]
|
||||
, instance' (var "Show" @@ var "Bool")
|
||||
[ typeSig "show" $ var "Bool" --> var "String"
|
||||
, funBinds "show"
|
||||
[ match [var "True"] $ string "True"
|
||||
, match [var "False"] $ string "False"
|
||||
[ match [conP "True" []] $ string "True"
|
||||
, match [conP "False" []] $ string "False"
|
||||
]
|
||||
]
|
||||
, data' "X" ["b"]
|
||||
@ -192,8 +192,8 @@ test3 = pprint $ module' Nothing Nothing []
|
||||
[]
|
||||
, funBind "strictness"
|
||||
$ match
|
||||
[strictP (conP "A" [var "b"]),
|
||||
lazyP (conP "A" [var "b"])
|
||||
[strictP (conP "A" [bvar "b"]),
|
||||
lazyP (conP "A" [bvar "b"])
|
||||
] (char 'x')
|
||||
, typeSig "unit" $ unit --> unit
|
||||
, funBind "unit" $ match [unit] unit
|
||||
@ -222,6 +222,6 @@ constModule = module' (Just "Const") (Just [var "const"]) []
|
||||
, funBind "const" $ match [wildP, x] x
|
||||
]
|
||||
where
|
||||
a = var "a"
|
||||
b = var "b"
|
||||
x = var "x"
|
||||
a = bvar "a"
|
||||
b = bvar "b"
|
||||
x = bvar "x"
|
||||
|
||||
@ -133,7 +133,7 @@ exprsTest dflags = testGroup "Expr"
|
||||
, "A 'x'" :~ var "A" @@ char 'x'
|
||||
, "A \"xyz\"" :~ var "A" @@ string "xyz"
|
||||
, "(\\ x -> x) (\\ x -> x)" :~
|
||||
let f = lambda [var "x"] (var "x")
|
||||
let f = lambda [bvar "x"] (var "x")
|
||||
in f @@ f
|
||||
, "f x @t" :~ tyApp (var "f" @@ var "x") (var "t")
|
||||
, "f (x @t)" :~ var "f" @@ (tyApp (var "x") (var "t"))
|
||||
@ -149,7 +149,7 @@ exprsTest dflags = testGroup "Expr"
|
||||
(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")
|
||||
let f = lambda [bvar "x"] (var "x")
|
||||
in op f "." f
|
||||
, "x @s + y @t" :~
|
||||
op (var "x" `tyApp` var "s") "+" (var "y" `tyApp` var "t")
|
||||
@ -199,9 +199,9 @@ exprsTest dflags = testGroup "Expr"
|
||||
, 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' [ funBind "f" $ match [bvar "x"] $ int 1] (var "f")
|
||||
, "let f (A x) = 1 in f" :~
|
||||
let' [ funBind "f" $ match [conP "A" [var "x"]] $ int 1] (var "f")
|
||||
let' [ funBind "f" $ match [conP "A" [bvar "x"]] $ int 1] (var "f")
|
||||
]
|
||||
, test "do"
|
||||
-- TODO: add more tests.
|
||||
@ -213,20 +213,20 @@ exprsTest dflags = testGroup "Expr"
|
||||
|
||||
declsTest dflags = testGroup "Decls"
|
||||
[ test "patBind"
|
||||
[ "x = x" :~ patBind (var "x") (var "x")
|
||||
, "(x, y) = (y, x)" :~ patBind (tuple [var "x", var "y"])
|
||||
[ "x = x" :~ patBind (bvar "x") (var "x")
|
||||
, "(x, y) = (y, x)" :~ patBind (tuple [bvar "x", bvar "y"])
|
||||
(tuple [var "y", var "x"])
|
||||
, "(x, y)\n | test = (1, 2)\n | otherwise = (2, 3)" :~
|
||||
patBindGRHSs (tuple [var "x", var "y"])
|
||||
patBindGRHSs (tuple [bvar "x", bvar "y"])
|
||||
$ guardedRhs
|
||||
[ var "test" `guard` tuple [int 1, int 2]
|
||||
, var "otherwise" `guard` tuple [int 2, int 3]
|
||||
]
|
||||
, "z | Just y <- x, y = ()" :~
|
||||
patBindGRHSs (var "z")
|
||||
patBindGRHSs (bvar "z")
|
||||
$ guardedRhs
|
||||
[guards
|
||||
[ conP "Just" [var "y"] <-- var "x"
|
||||
[ conP "Just" [bvar "y"] <-- var "x"
|
||||
, stmt (var "y")
|
||||
]
|
||||
unit
|
||||
@ -246,16 +246,16 @@ declsTest dflags = testGroup "Decls"
|
||||
, test "funBind"
|
||||
[ "not True = False\nnot False = True" :~
|
||||
funBinds "not"
|
||||
[ match [var "True"] (var "False")
|
||||
, match [var "False"] (var "True")
|
||||
[ match [bvar "True"] (var "False")
|
||||
, match [bvar "False"] (var "True")
|
||||
]
|
||||
, "not x\n | x = False\n | otherwise = True" :~
|
||||
funBind "not"
|
||||
$ matchGRHSs [var "x"] $ guardedRhs
|
||||
$ matchGRHSs [bvar "x"] $ guardedRhs
|
||||
[ guard (var "x") (var "False")
|
||||
, guard (var "otherwise") (var "True")
|
||||
]
|
||||
, "f (A x) = 1" :~ funBind "f" $ match [conP "A" [var "x"]] (int 1)
|
||||
, "f (A x) = 1" :~ funBind "f" $ match [conP "A" [bvar "x"]] (int 1)
|
||||
]
|
||||
, test "tyFamInst"
|
||||
[ "type instance Elt String = Char"
|
||||
@ -270,7 +270,7 @@ declsTest dflags = testGroup "Decls"
|
||||
]
|
||||
, test "patSynBind"
|
||||
[ "pattern F a b = G b a"
|
||||
:~ patSynBind "F" ["a", "b"] $ conP "G" [var "b", var "a"]
|
||||
:~ patSynBind "F" ["a", "b"] $ conP "G" [bvar "b", bvar "a"]
|
||||
]
|
||||
]
|
||||
where
|
||||
@ -278,15 +278,15 @@ declsTest dflags = testGroup "Decls"
|
||||
|
||||
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 x y" :~ conP "A" [bvar "x", bvar "y"]
|
||||
, "(:) x y" :~ conP ":" [bvar "x", bvar "y"]
|
||||
, "(Prelude.:) x" :~ conP "Prelude.:" [bvar "x"]
|
||||
, "A (B x)" :~ conP "A" [conP "B" [bvar "x"]]
|
||||
, "A (B x)" :~ conP "A" [par $ conP "B" [bvar "x"]]
|
||||
, "A ((B x))" :~ conP "A" [par $ par $ conP "B" [bvar "x"]]
|
||||
, "A x (B y z)" :~ conP "A" [bvar "x", conP "B" [bvar "y", bvar "z"]]
|
||||
, "A w (B x y) Z"
|
||||
:~ conP "A" [var "w", conP "B" [var "x", var "y"], conP "Z" []]
|
||||
:~ conP "A" [bvar "w", conP "B" [bvar "x", bvar "y"], conP "Z" []]
|
||||
, "A 3" :~ conP "A" [int 3]
|
||||
, "A (-3)" :~ conP "A" [int (-3)]
|
||||
, "A 3.0" :~ conP "A" [frac 3.0]
|
||||
@ -298,24 +298,24 @@ patsTest dflags = testGroup "Pats"
|
||||
]
|
||||
, test "asP"
|
||||
[ "x@B" :~ asP "x" $ conP "B" []
|
||||
, "x@(B y)" :~ asP "x" $ conP "B" [var "y"]
|
||||
, "x@(B y)" :~ asP "x" $ conP "B" [bvar "y"]
|
||||
, "x@_" :~ asP "x" wildP
|
||||
]
|
||||
, test "strictP"
|
||||
[ "!x" :~ strictP $ var "x"
|
||||
[ "!x" :~ strictP $ bvar "x"
|
||||
, "!B" :~ strictP $ conP "B" []
|
||||
, "!(B y)" :~ strictP $ conP "B" [var "y"]
|
||||
, "!(B y)" :~ strictP $ conP "B" [bvar "y"]
|
||||
, "!_" :~ strictP wildP
|
||||
]
|
||||
, test "lazyP"
|
||||
[ "~x" :~ lazyP $ var "x"
|
||||
[ "~x" :~ lazyP $ bvar "x"
|
||||
, "~B" :~ lazyP $ conP "B" []
|
||||
, "~(B y)" :~ lazyP $ conP "B" [var "y"]
|
||||
, "~(B y)" :~ lazyP $ conP "B" [bvar "y"]
|
||||
, "~_" :~ lazyP wildP
|
||||
]
|
||||
, test "sigPat"
|
||||
[ "x :: A" :~ sigP (var "x") (var "A")
|
||||
, "A x :: A x" :~ sigP (conP "A" [var "x"]) (var "A" @@ var "x")
|
||||
[ "x :: A" :~ sigP (bvar "x") (bvar "A")
|
||||
, "A x :: A x" :~ sigP (conP "A" [bvar "x"]) (bvar "A" @@ bvar "x")
|
||||
]
|
||||
, test "recordConP"
|
||||
[ "A {x = Y}" :~ recordConP "A" [("x", conP "Y" [])]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user