ghc-source-gen 0.1.0.0 → 0.2

raw patch · 25 files changed

+1305/−378 lines, 25 filesdep +QuickCheckdep +tasty-quickcheckdep ~tastydep ~tasty-hunitPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, tasty-quickcheck

Dependency ranges changed: tasty, tasty-hunit

API changes (from Hackage documentation)

Files

• ChangeLog.md +30/−1
• README.md +6/−6
• ghc-source-gen.cabal +32/−8
• src/GHC/SourceGen.hs +2/−4
• src/GHC/SourceGen/Binds.hs +101/−45
• src/GHC/SourceGen/Binds/Internal.hs +31/−3
• src/GHC/SourceGen/Decl.hs +167/−53
• src/GHC/SourceGen/Expr.hs +94/−9
• src/GHC/SourceGen/Expr/Internal.hs +2/−22
• src/GHC/SourceGen/Lit.hs +13/−5
• src/GHC/SourceGen/Lit/Internal.hs +25/−1
• src/GHC/SourceGen/Module.hs +56/−2
• src/GHC/SourceGen/Name.hs +30/−6
• src/GHC/SourceGen/Name/Internal.hs +70/−20
• src/GHC/SourceGen/Overloaded.hs +27/−10
• src/GHC/SourceGen/Pat.hs +59/−10
• src/GHC/SourceGen/Pat/Internal.hs +40/−0
• src/GHC/SourceGen/Syntax.hs +0/−109
• src/GHC/SourceGen/Syntax/Internal.hs +197/−3
• src/GHC/SourceGen/Type.hs +20/−3
• src/GHC/SourceGen/Type/Internal.hs +6/−4
• tests/GhcVersion.hs +16/−0
• tests/name_test.hs +70/−0
• tests/pprint_examples.hs +46/−39
• tests/pprint_test.hs +165/−15

@@ -1,3 +1,32 @@ # Changelog for haskell-syntax -## Unreleased changes+## 0.2+- Improve overall documentation..+- Move `patBind` to a new `HasPatBind` class so that it can be used+  with `let'` and `while'`.+- Remove `GHC.SourceGen.Syntax` and export types from relevant modules+  (for example, `HsType'` from `GHC.SourceGen.Type`).+- Refactor the treatment of names:+    - Rename the constructors of `RdrNameStr`.+    - Make some combinators take `OccNameStr` instead of `RdrNameStr`, and+      introduce the `BVar` class for patterns.+    - Add `Eq` and `Ord` instances.+- Support more kinds of syntax:+    - Deriving clauses+    - Import/export lists+    - Record expressions and patterns+    - Type family instances+    - Pattern synonyms (currently, only the prefix form)+- Refactor the names and types of `match` and related combinators,+  optimizing for the common case of a single expression on the RHS.+- Fix edge cases when parsing qualified operators.+- Add parentheses in some cases that were previously missing them.+- Make `==>` have the same precedence as `-->` to make it easier to+  combine them.+- Make `tyApp`'s precedence match `-XTypeApplications`.+- Fix pretty-printing of rational literals.+- Make `tyPromotedVar` pretty-print as `'Abc` not `Abc`.+- Add `conP_` for pattern constructors with no arguments.++## 0.1.0.0+Initial version.

@@ -1,7 +1,7 @@ # ghc-source-gen  `ghc-source-gen` is a Haskell library for generating Haskell source files and-code fragments.  It uses GHC's [library API] for the latest up-to-date syntax, and+code fragments.  It uses GHC's [library API] to support the latest syntax, and provides a simple, consistent interface across several major versions of GHC.  To get started, take a look at the [example](#example) below, or check out the@@ -26,12 +26,12 @@ 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"     b = var "b"-    x = var "x"+    x = bvar "x"  main = runGhc (Just libdir) $ putPpr constModule ```@@ -57,12 +57,12 @@  Currently, this library supports GHC versions 8.2, 8.4, 8.6 and 8.8. -One caveat: in the future, `ghc-source-gen` will support some forms of syntax+One caveat: `ghc-source-gen` supports some forms of syntax which are not implemented by all of those GHC versions.  For example, the `DerivingVia` extension is only implemented in `ghc >= 8.6`.  When built on older versions of GHC, `ghc-source-gen` will omit functions for constructing-that syntax.  We will also tag any such function with a note in its Haddock-documentation.+that syntax (for example: `GHC.SourceGen.Decl.derivingVia`).  We will also tag+any such function with a note in its Haddock documentation.  ### Less verbose types and construction functions 

@@ -1,11 +1,13 @@--- This file has been generated from package.yaml by hpack version 0.28.2.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack ----- hash: bbf81e9b932cf501a87fab8a5ebcea3df292f1cab234cad74fb08185047e9388+-- hash: d258230cc8bfea9db929dae746e49c293d139750bf25c9cfea165f47793cf26b  name:           ghc-source-gen-version:        0.1.0.0+version:        0.2 synopsis:       Constructs Haskell syntax trees for the GHC API. description:    @ghc-source-gen@ is a library for generating Haskell source code.                 It uses the <https://hackage.haskell.org/package/ghc ghc> library@@ -24,10 +26,9 @@ license:        BSD3 license-file:   LICENSE build-type:     Simple-cabal-version:  >= 1.10 extra-source-files:-    ChangeLog.md     README.md+    ChangeLog.md  source-repository head   type: git@@ -44,8 +45,8 @@       GHC.SourceGen.Name       GHC.SourceGen.Overloaded       GHC.SourceGen.Pat+      GHC.SourceGen.Pat.Internal       GHC.SourceGen.Pretty-      GHC.SourceGen.Syntax       GHC.SourceGen.Type   other-modules:       GHC.SourceGen.Binds.Internal@@ -62,10 +63,30 @@     , ghc >=8.2 && <8.9   default-language: Haskell2010 +test-suite name_test+  type: exitcode-stdio-1.0+  main-is: name_test.hs+  other-modules:+      GhcVersion+      Paths_ghc_source_gen+  hs-source-dirs:+      tests+  default-extensions: DataKinds FlexibleInstances TypeSynonymInstances+  build-depends:+      QuickCheck >=2.10 && <2.13+    , base >=4.7 && <5+    , ghc >=8.2 && <8.9+    , ghc-source-gen+    , tasty >=1.0 && <1.3+    , tasty-hunit ==0.10.*+    , tasty-quickcheck >=0.9 && <0.11+  default-language: Haskell2010+ test-suite pprint_examples   type: exitcode-stdio-1.0   main-is: pprint_examples.hs   other-modules:+      GhcVersion       Paths_ghc_source_gen   hs-source-dirs:       tests@@ -75,12 +96,15 @@     , ghc >=8.2 && <8.9     , ghc-paths ==0.1.*     , ghc-source-gen+    , tasty >=1.0 && <1.3+    , tasty-hunit ==0.10.*   default-language: Haskell2010  test-suite pprint_test   type: exitcode-stdio-1.0   main-is: pprint_test.hs   other-modules:+      GhcVersion       Paths_ghc_source_gen   hs-source-dirs:       tests@@ -90,6 +114,6 @@     , ghc >=8.2 && <8.9     , ghc-paths ==0.1.*     , ghc-source-gen-    , tasty-    , tasty-hunit+    , tasty >=1.0 && <1.3+    , tasty-hunit ==0.10.*   default-language: Haskell2010

@@ -13,7 +13,6 @@     ( -- * Syntax types       -- | These modules declare combinators for constructing different parts       -- of a GHC syntax tree.-      module GHC.SourceGen.Syntax,       module GHC.SourceGen.Name,       module GHC.SourceGen.Decl,       module GHC.SourceGen.Expr,@@ -23,11 +22,11 @@       -- * Overloaded combinators       -- | Certain concepts make sense in different       -- parts of Haskell syntax.  For example, 'var' may be used in-      -- expressions, types, patterns, and import or export lists.+      -- expressions, types, and import or export lists.       module GHC.SourceGen.Binds,       module GHC.SourceGen.Lit,       module GHC.SourceGen.Overloaded,-      -- * Renders Haskell syntax into text+      -- * Rendering Haskell syntax into text       module GHC.SourceGen.Pretty,     ) where @@ -40,6 +39,5 @@ import GHC.SourceGen.Overloaded import GHC.SourceGen.Pat import GHC.SourceGen.Pretty-import GHC.SourceGen.Syntax import GHC.SourceGen.Type 

@@ -6,23 +6,34 @@  -- | This module provides combinators for constructing Haskell declarations. module GHC.SourceGen.Binds-    ( -- * Overloaded constructors-      HasValBind(..)+    (  -- * Bindings+      HsBind'+    , HasValBind+      -- * Type signatures     , typeSig     , typeSigs+      -- * Functions     , funBind     , funBinds+      -- * Values+    , valBind+    , valBindGRHSs+    -- ** Patterns+    , HasPatBind+    , patBind+    , patBindGRHSs     -- * Matches     -- $rawMatch     , RawMatch     , match-    , matchRhs+    , matchGRHSs     -- * Right-hand sides     , RawGRHSs     , rhs     -- ** Guards     , guardedRhs     , GuardedExpr+    , GRHS'     , guards     , guard     -- ** Where clauses@@ -36,73 +47,125 @@ import BasicTypes (LexicalFixity(..)) import HsBinds import HsExpr-import HsDecls import HsTypes import TcEvidence (HsWrapper(WpHole))  import GHC.SourceGen.Binds.Internal+import GHC.SourceGen.Name import GHC.SourceGen.Name.Internal-import GHC.SourceGen.Syntax import GHC.SourceGen.Syntax.Internal import GHC.SourceGen.Type.Internal (sigWcType) --- | Declare that a multiple functions or values have a type:+-- | Declares the type of multiple functions or values. -- -- > f, g :: A -- > ===== -- > typeSigs ["f", "g"] (var "A")-typeSigs :: HasValBind t => [RdrNameStr] -> HsType' -> t+typeSigs :: HasValBind t => [OccNameStr] -> HsType' -> t typeSigs names t =-    sigB $ noExt TypeSig (map typeRdrName names)+    sigB $ noExt TypeSig (map (typeRdrName . unqual) names)         $ sigWcType t --- | Declare that a function or value has a type:+-- | Declares the type of a single function or value. -- -- > f :: A -- > ===== -- > typeSig "f" (var "A")-typeSig :: HasValBind t => RdrNameStr -> HsType' -> t+typeSig :: HasValBind t => OccNameStr -> HsType' -> t typeSig n = typeSigs [n] --- | Define a function or value.+-- | Defines a function or value. -- -- > 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 => RdrNameStr -> [RawMatch] -> t+funBinds :: HasValBind t => OccNameStr -> [RawMatch] -> t funBinds name matches = bindB $ withPlaceHolder         (noExt FunBind name'             (matchGroup context matches) WpHole)         []   where-    name' = valueRdrName name+    name' = valueRdrName $ unqual name     context = FunRhs name' Prefix NoSrcStrict  -- | Defines a function that has a single case. -- -- > f = x -- > =====--- > funBind "f" (matchRhs [] "x")+-- > funBind "f" (match [] "x") -- -- > id x = x -- > =====--- > funBind "id" $ matchRhs [var "x"] (var "x")+-- > funBind "id" $ match [bvar "x"] (var "x") ---funBind :: HasValBind t => RdrNameStr -> RawMatch -> t+funBind :: HasValBind t => OccNameStr -> RawMatch -> t funBind name m = funBinds name [m] +-- | Defines a value consisting of multiple guards.+--+-- The resulting syntax is the same as a function with no arguments.+--+-- > x+-- >   | test = 1+-- >   | otherwise = 2+-- > =====+-- > valBindGRHSs "x"+-- >   $ guardedRhs+-- >       [ 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.+--+-- The resulting syntax is the same as a function with no arguments.+--+-- > x = y+-- > =====+-- > 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)+-- >   | test = (1, 2)+-- >   | otherwise = (2, 3)+-- > =====+-- > patBindGrhs (tuple [bvar "x", bvar "y"])+-- >   $ guardedRhs+-- >       [ var "test" `guard` tuple [int 1, int 2]+-- >       , var "otherwise" `guard` [int 2, int 3]+-- >       ]+patBindGRHSs :: HasPatBind t => Pat' -> RawGRHSs -> t+patBindGRHSs p g =+    bindB+        $ withPlaceHolder+            (withPlaceHolder+                (noExt PatBind (builtPat p) (mkGRHSs g)))+        $ ([],[])++-- | Defines a pattern binding without any guards.+--+-- > (x, y) = e+-- > =====+-- > patBind (tuple [bvar "x", bvar "y"]) e+patBind :: HasPatBind t => Pat' -> HsExpr' -> t+patBind p = patBindGRHSs p . rhs+ {- $rawMatch  A function definition is made up of one or more 'RawMatch' terms.  Each@@ -115,8 +178,8 @@ 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@@ -129,19 +192,19 @@ We would say:  > funBind "not"->      $ match [var "x"] $ guardedRhs+>      $ matchGRHSs [bvar "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'. --@@ -149,9 +212,9 @@ -- >   where y = x -- > ===== -- > funBind "x"--- >   $ match [var "x"]+-- >   $ matchGRHSs [bvar "x"] -- >   $ rhs (var "y")--- >      `where` [patBind (var "y") $ rhs $ var "x']+-- >      `where` [valBind "y" $ var "x'] where' :: RawGRHSs -> [RawValBind] -> RawGRHSs where' r vbs = r { rawGRHSWhere = rawGRHSWhere r ++ vbs } @@ -183,7 +246,7 @@ -- -- >   | 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) @@ -200,24 +263,17 @@ -- -- > 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 <-- --- | Syntax types which can declare/define functions.  For example:--- declarations, or the body of a class declaration or class instance.+-- | Syntax types which can declare/define pattern bindings.+-- For example: declarations at the top-level or in let/where clauses. ----- Use 'typeSig' or 'typeSigs' to declare that functions or values have--- types, and use 'funBind' to give them definitions.-class HasValBind t where-    sigB :: Sig' -> t-    bindB :: HsBind' -> t--instance HasValBind RawValBind where-    sigB = SigV-    bindB = BindV+-- Note: this class is more restrictive than 'HasValBind' since pattern+-- bindings cannot be used in class or instance declarations.+class HasValBind t => HasPatBind t where -instance HasValBind HsDecl' where-    sigB = noExt SigD-    bindB = noExt ValD+instance HasPatBind RawValBind where+instance HasPatBind HsDecl' where

@@ -10,6 +10,7 @@ import BasicTypes (Origin(Generated)) import Bag (listToBag) import HsBinds+import HsDecls import HsExpr (MatchGroup(..), Match(..), GRHSs(..)) import SrcLoc (Located) @@ -17,10 +18,14 @@ import PlaceHolder (PlaceHolder(..)) #endif --import GHC.SourceGen.Syntax+import GHC.SourceGen.Pat.Internal (parenthesize) import GHC.SourceGen.Syntax.Internal +-- | A binding definition inside of a @let@ or @where@ clause.+--+-- 'RawValBind' definitions may be constructed using its instance of+-- 'HasValBind'.  For more details, see the documentation of that function, and+-- of "GHC.SourceGen.Binds" overall. data RawValBind     = SigV Sig'     | BindV HsBind'@@ -81,7 +86,8 @@                             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.@@ -101,3 +107,25 @@ -- > | otherwise = () type GuardedExpr = GRHS' (Located HsExpr') +-- | Syntax types which can declare/define functions.  For example:+-- declarations, or the body of a class declaration or class instance.+--+-- To declare the type of a function or value, use+-- 'GHC.SourceGen.Binds.typeSig' or 'GHC.SourceGen.Binds.typeSigs'.+--+-- To define a function, use +-- 'GHC.SourceGen.Binds.funBind' or 'GHC.SourceGen.Binds.funBinds'.+--+-- To define a value, use+-- 'GHC.SourceGen.Binds.valBind' or 'GHC.SourceGen.Binds.valBindGuarded'.+class HasValBind t where+    sigB :: Sig' -> t+    bindB :: HsBind' -> t++instance HasValBind HsDecl' where+    sigB = noExt SigD+    bindB = noExt ValD++instance HasValBind RawValBind where+    sigB = SigV+    bindB = BindV

@@ -7,13 +7,13 @@ {-# LANGUAGE CPP #-} -- | This module provides combinators for constructing Haskell declarations. module GHC.SourceGen.Decl-    ( -- * Type declarations-      type'+    ( HsDecl'+      -- * Type declarations+    , type'     , newtype'     , data'-      -- * Pattern bindings-    , patBind-      -- * Data constructors+      -- ** Data constructors+    , ConDecl'     , prefixCon     , infixCon     , recordCon@@ -21,6 +21,15 @@     , field     , strict     , lazy+      -- ** Deriving clauses+    , HsDerivingClause'+    , deriving'+    , derivingStock+    , derivingAnyclass+    , derivingNewtype+#if MIN_VERSION_ghc(8,6,0)+    , derivingVia+#endif       -- * Class declarations     , class'     , ClassDecl@@ -28,11 +37,20 @@       -- * Instance declarations     , instance'     , RawInstDecl+    , HasTyFamInst(..)+    , tyFamInst+      -- * Pattern synonyms+    , patSynSigs+    , patSynSig+    , patSynBind     ) where  import BasicTypes (LexicalFixity(Prefix))+#if !MIN_VERSION_ghc(8,6,0)+import BasicTypes (DerivStrategy(..))+#endif import Bag (listToBag)-import HsBinds (HsBindLR(..))+import HsBinds import HsDecls import HsTypes     ( ConDeclField(..)@@ -40,6 +58,9 @@     , HsConDetails(..)     , HsSrcBang(..)     , HsType(..)+#if MIN_VERSION_ghc(8,8,0)+    , HsArg(..)+#endif     , SrcStrictness(..)     , SrcUnpackedness(..)     )@@ -51,15 +72,18 @@ import PlaceHolder (PlaceHolder(..)) #endif -import GHC.SourceGen.Binds-import GHC.SourceGen.Binds.Internal (mkGRHSs)+import GHC.SourceGen.Binds.Internal import GHC.SourceGen.Lit.Internal (noSourceText)+import GHC.SourceGen.Name import GHC.SourceGen.Name.Internal-import GHC.SourceGen.Syntax import GHC.SourceGen.Syntax.Internal import GHC.SourceGen.Type.Internal  -- | A definition that can appear in the body of a @class@ declaration.+--+-- 'ClassDecl' definitions may be constructed using 'funDep' or using the+-- instance of 'HasValBind'.  For more details, see the documentation of+-- that function, and of "GHC.SourceGen.Binds" overall. data ClassDecl     = ClassSig Sig'     | ClassDefaultMethod HsBind'@@ -108,13 +132,13 @@ -- >      [ typeSig "divMod" $ a --> a --> tuple [a, a] -- >      , typeSig "div" $ a --> a --> a -- >      , funBind "div"--- >          $ matchRhs [var "x", var "y"]+-- >          $ match [bvar "x", bvar "y"] -- >             $ var "fst" @@ (var "divMod" @@ var "x" @@ var "y") -- >      ] class'     :: [HsType'] -- ^ Context-    -> RdrNameStr -- ^ Class name-    -> [RdrNameStr] -- ^ Type parameters+    -> OccNameStr -- ^ Class name+    -> [OccNameStr] -- ^ Type parameters     -> [ClassDecl] -- ^ Class declarations     -> HsDecl' class' context name vars decls@@ -125,7 +149,7 @@ #else             , tcdFVs = PlaceHolder #endif-            , tcdLName = typeRdrName name+            , tcdLName = typeRdrName $ unqual name             , tcdTyVars = mkQTyVars vars             , tcdFixity = Prefix             , tcdFDs = [ builtLoc (map typeRdrName xs, map typeRdrName ys)@@ -140,9 +164,13 @@             }  -- | A definition that can appear in the body of an @instance@ declaration.+--+-- 'RawInstDecl' definitions may be constructed using its class instances, e.g.,+-- 'HasValBind'.  For more details, see the documentation of those classes. data RawInstDecl     = InstSig Sig'     | InstBind HsBind'+    | InstTyFam TyFamInstDecl'  instance HasValBind RawInstDecl where     sigB = InstSig@@ -158,8 +186,8 @@ -- > instance' (var "Show" @@ var "Bool") -- >   [ typeSig "show" $ var "Bool" --> var "String" -- >   , funBinds "show"--- >       [ matchRhs [var "True"] $ string "True"--- >       , matchRhs [var "False"] $ string "False"+-- >       [ match [bvar "True"] $ string "True"+-- >       , match [bvar "False"] $ string "False" -- >       ] -- >   ] instance' :: HsType' -> [RawInstDecl] -> HsDecl'@@ -170,53 +198,101 @@ #endif     , cid_binds = listToBag [builtLoc b | InstBind b <- decls]     , cid_sigs = [builtLoc sig | InstSig sig <- decls]-    , cid_tyfam_insts = []+    , cid_tyfam_insts = [builtLoc $ t | InstTyFam t <- decls]     , cid_datafam_insts = []     , cid_overlap_mode = Nothing     } +-- | Terms which can contain a type instance declaration.+--+-- To use this class, call 'tyFamInst'.+class HasTyFamInst t where+    tyFamInstD :: TyFamInstDecl' -> t++instance HasTyFamInst HsDecl' where+    tyFamInstD = noExt InstD . noExt TyFamInstD++instance HasTyFamInst RawInstDecl where+    tyFamInstD = InstTyFam++-- | A type family instance.+--+-- > type Elt String = Char+-- > =====+-- > tyFamInst "Elt" [var "String"] (var "Char")+tyFamInst :: HasTyFamInst t => RdrNameStr -> [HsType'] -> HsType' -> t+tyFamInst name params ty = tyFamInstD+#if MIN_VERSION_ghc(8,4,0)+        $ TyFamInstDecl+        $ implicitBndrs+        $ noExt FamEqn (typeRdrName name)+#if MIN_VERSION_ghc(8,8,0)+            Nothing -- eqn binders+            (map (HsValArg . builtLoc) params)+#else+            (map builtLoc params)+#endif+            Prefix+            (builtLoc ty)+#else+        $ withPlaceHolder $ TyFamInstDecl+        $ builtLoc $ TyFamEqn (typeRdrName name)+                        (implicitBndrs $ map builtLoc params)+                        Prefix+                        (builtLoc ty)+#endif+ -- | Declares a type synonym. -- -- > type A a b = B b a -- > ===== -- > type' "A" ["a", "b"] $ var "B" @@ var "b" @@ var "a"-type' :: RdrNameStr -> [RdrNameStr] -> HsType' -> HsDecl'+type' :: OccNameStr -> [OccNameStr] -> HsType' -> HsDecl' type' name vars t =-    noExt TyClD $ withPlaceHolder $ noExt SynDecl (typeRdrName name)+    noExt TyClD $ withPlaceHolder $ noExt SynDecl (typeRdrName $ unqual name)         (mkQTyVars vars)         Prefix         (builtLoc t) -newOrDataType ::-    NewOrData -> RdrNameStr -> [RdrNameStr] -> [ConDecl'] -> HsDecl'-newOrDataType newOrData name vars conDecls+newOrDataType+    :: NewOrData+    -> OccNameStr+    -> [OccNameStr]+    -> [ConDecl']+    -> [HsDerivingClause']+    -> HsDecl'+newOrDataType newOrData name vars conDecls derivs     = noExt TyClD $ withPlaceHolder $ withPlaceHolder $-        noExt DataDecl (typeRdrName name)+        noExt DataDecl (typeRdrName $ unqual name)             (mkQTyVars vars)             Prefix             $ noExt HsDataDefn newOrData                 (builtLoc []) Nothing                 Nothing                 (map builtLoc conDecls)-                (builtLoc [])+                (builtLoc $ map builtLoc derivs)  -- | A newtype declaration. ----- > newtype Const a b = Const a+-- > newtype Const a b = Const a deriving Eq -- > =====--- > newtype' "Const" ["a", "b"] $ conDecl "Const" [var "a"]-newtype' :: RdrNameStr -> [RdrNameStr] -> ConDecl' -> HsDecl'+-- > newtype' "Const" ["a", "b"]+-- >    (conDecl "Const" [var "a"])+-- >    [var "Show"]+newtype' :: OccNameStr -> [OccNameStr] -> ConDecl' -> [HsDerivingClause'] -> HsDecl' newtype' name vars conD = newOrDataType NewType name vars [conD]  -- | A data declaration. -- -- > data Either a b = Left a | Right b+-- >    deriving Show -- > ===== -- > data' "Either" ["a", "b"] -- >   [ conDecl "Left" [var "a"] -- >   , conDecl "Right" [var "b"] -- >   ]-data' :: RdrNameStr -> [RdrNameStr] -> [ConDecl'] -> HsDecl'+-- >   [var "Show"]+data' :: OccNameStr -> [OccNameStr] -> [ConDecl'] -> [HsDerivingClause'] -> HsDecl' data' = newOrDataType DataType  -- | Declares a Haskell-98-style prefix constructor for a data or type@@ -225,7 +301,7 @@ -- > Foo a Int -- > ===== -- > conDecl "Foo" [field (var "a"), field (var "Int")]-prefixCon :: RdrNameStr -> [Field] -> ConDecl'+prefixCon :: OccNameStr -> [Field] -> ConDecl' prefixCon name fields = renderCon98Decl name     $ PrefixCon $ map renderField fields @@ -235,7 +311,7 @@ -- > A b :+: C d -- > ===== -- > infixCon (field (var "A" @@ var "b")) ":+:" (field (Var "C" @@ var "d"))-infixCon :: Field -> RdrNameStr -> Field -> ConDecl'+infixCon :: Field -> OccNameStr -> Field -> ConDecl' infixCon f name f' = renderCon98Decl name     $ InfixCon (renderField f) (renderField f') @@ -245,13 +321,13 @@ -- > A { x :: B, y :: C } -- > ===== -- > recordCon "A" [("x", var "B"), ("y", var "C")]-recordCon :: RdrNameStr -> [(RdrNameStr, Field)] -> ConDecl'+recordCon :: OccNameStr -> [(OccNameStr, Field)] -> ConDecl' recordCon name fields = renderCon98Decl name     $ RecCon $ builtLoc $ map mkLConDeclField fields   where     mkLConDeclField (n, f) =         builtLoc $ noExt ConDeclField-                        [builtLoc $ withPlaceHolder $ noExt FieldOcc $ valueRdrName n]+                        [builtLoc $ withPlaceHolder $ noExt FieldOcc $ valueRdrName $ unqual n]                         (renderField f)                         Nothing @@ -298,8 +374,8 @@         NoSrcStrict -> id         s -> builtLoc . (noExt HsBangTy $ noSourceText HsSrcBang NoSrcUnpack s) -renderCon98Decl :: RdrNameStr -> HsConDeclDetails' -> ConDecl'-renderCon98Decl name details = noExt ConDeclH98 (typeRdrName name)+renderCon98Decl :: OccNameStr -> HsConDeclDetails' -> ConDecl'+renderCon98Decl name details = noExt ConDeclH98 (typeRdrName $ unqual name) #if MIN_VERSION_ghc(8,6,0)     (builtLoc False)     []@@ -310,29 +386,67 @@     details     Nothing --- | A pattern binding.+deriving' :: [HsType'] -> HsDerivingClause'+deriving' = derivingWay Nothing++derivingWay :: Maybe DerivStrategy' -> [HsType'] -> HsDerivingClause'+derivingWay way ts =+    noExt HsDerivingClause (fmap builtLoc way) $ builtLoc $ map sigType ts++derivingStock :: [HsType'] -> HsDerivingClause'+derivingStock = derivingWay (Just StockStrategy)++derivingNewtype :: [HsType'] -> HsDerivingClause'+derivingNewtype = derivingWay (Just NewtypeStrategy)++derivingAnyclass :: [HsType'] -> HsDerivingClause'+derivingAnyclass = derivingWay (Just AnyclassStrategy)++#if MIN_VERSION_ghc(8,6,0)+-- | A `DerivingVia` clause. ----- > x = y+-- > deriving (Eq, Show) via T -- > =====--- > patBind (var "x") $ rhs $ var "y"+-- > derivingVia (var "T") [var "Eq", var "Show"]+-- Available with @ghc>=8.6@.+derivingVia :: HsType' -> [HsType'] -> HsDerivingClause'+derivingVia t = derivingWay (Just $ ViaStrategy $ sigType t)+#endif++-- | Declares multiple pattern signatures of the same type. ----- > (x, y) = e+-- > pattern F, G :: T -- > =====--- > patBind (tuple [var "x", var "y"]) $ rhs e+-- > patSynSigs ["F", "G"] $ var "T"+patSynSigs :: [OccNameStr] -> HsType' -> HsDecl'+patSynSigs names t =+    sigB $ noExt PatSynSig (map (typeRdrName . unqual) names)+        $ sigType t++-- | Declares a pattern signature and its type. ----- > (x, y)--- >   | test = (1, 2)--- >   | otherwise = (2, 3)+-- > pattern F :: T -- > =====--- > patBind (tuple [var "x", var "y"])--- >   $ guardedRhs--- >       [ var "test" `guard` tuple [int 1, int 2]--- >       , var "otherwise" `guard` [int 2, int 3]--- >       ]-patBind :: Pat' -> RawGRHSs -> HsDecl'-patBind p g =-    bindB-        $ withPlaceHolder-            (withPlaceHolder-                (noExt PatBind (builtPat p) (mkGRHSs g)))-        $ ([],[])+-- > patSynSigs "F" $ var "T"+patSynSig :: OccNameStr -> HsType' -> HsDecl'+patSynSig n = patSynSigs [n]++-- TODO: patSynBidi, patSynUni++-- | Defines a pattern signature.+--+-- > pattern F a b = G b a+-- > =====+-- > patSynBind "F" ["a", "b"] $ conP "G" [bvar "b", bvar "a"]+patSynBind :: OccNameStr -> [OccNameStr] -> Pat' -> HsDecl'+patSynBind n ns p = bindB $ noExt PatSynBind+                    $ withPlaceHolder (noExt PSB (valueRdrName $ unqual n))+#if MIN_VERSION_ghc(8,4,0)+                        (PrefixCon+#else+                        (PrefixPatSyn+#endif+                            (map (valueRdrName . unqual) ns))+                        (builtPat p)+                        ImplicitBidirectional+

@@ -6,15 +6,33 @@  {-# LANGUAGE CPP #-} -- | This module provides combinators for constructing Haskell expressions.-module GHC.SourceGen.Expr where+module GHC.SourceGen.Expr+    ( HsExpr'+    , overLabel+    , let'+    , case'+    , lambda+    , lambdaCase+    , if'+    , multiIf+    , do'+    , Stmt'+    , (@::@)+    , tyApp+    , recordConE+    , recordUpd+    ) where  import HsExpr+import HsPat (HsRecField'(..), HsRecFields(..))+import HsTypes (FieldOcc(..), AmbiguousFieldOcc(..)) import Data.String (fromString)-import SrcLoc (unLoc)+import SrcLoc (unLoc, GenLocated(..), Located)  import GHC.SourceGen.Binds.Internal import GHC.SourceGen.Binds-import GHC.SourceGen.Syntax+import GHC.SourceGen.Expr.Internal+import GHC.SourceGen.Name.Internal import GHC.SourceGen.Syntax.Internal import GHC.SourceGen.Type.Internal     ( parenthesizeTypeForApp@@ -38,7 +56,7 @@                     $ 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@@ -68,9 +86,23 @@ -- >   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+do' = withPlaceHolder . noExt HsDo DoExpr+        . builtLoc . map (builtLoc . parenthesizeIfLet)+  where+  -- Put parentheses around a "let" in a do-binding, to avoid:+  --   do let x = ...+  --      in x+  -- which is not valid Haskell.+#if MIN_VERSION_ghc(8,6,0)+    parenthesizeIfLet (BodyStmt ext e@(L _ HsLet{}) x y)+        = BodyStmt ext (parExpr e) x y+#else+    parenthesizeIfLet (BodyStmt e@(L _ HsLet{}) x y tc)+        = BodyStmt (parExpr e) x y tc+#endif+    parenthesizeIfLet s = s  -- | A type constraint on an expression. --@@ -94,11 +126,64 @@ -- > var "f" @@ var "Int" tyApp :: HsExpr' -> HsType' -> HsExpr' #if MIN_VERSION_ghc(8,8,0)-tyApp e t = noExt HsAppType (builtLoc e) t'+tyApp e t = noExt HsAppType e' t' #elif MIN_VERSION_ghc(8,6,0)-tyApp e t = HsAppType t' (builtLoc e)+tyApp e t = HsAppType t' e' #else-tyApp e t = HsAppType (builtLoc e) t'+tyApp e t = HsAppType e' t' #endif   where     t' = wcType $ unLoc $ parenthesizeTypeForApp $ builtLoc t+    e' = builtLoc e++-- | Constructs a record with explicit field names.+--+-- > A { x = y }+-- > =====+-- > recordConE "A" [("x", var "y")]+recordConE :: RdrNameStr -> [(RdrNameStr, HsExpr')] -> HsExpr'+recordConE c fs = (withPlaceHolder $ noExt RecordCon (valueRdrName c))+#if !MIN_VERSION_ghc(8,6,0)+                    noPostTcExpr+#endif+                    $ HsRecFields (map recField fs)+                        Nothing -- No ".."+  where+    recField :: (RdrNameStr, HsExpr') -> LHsRecField' (Located HsExpr')+    recField (f, e) =+        builtLoc HsRecField+            { hsRecFieldLbl =+                  builtLoc $ withPlaceHolder $ noExt FieldOcc $ valueRdrName f+            , hsRecFieldArg = builtLoc e+            , hsRecPun = False+            }++-- | Updates a record expression with explicit field names.+--+-- > r {a = b, c = d}+-- > =====+-- > recordUpd (var "x") [("a", var "b", ("c", var "d"))]+--+-- > (f x) {a = b}+-- > =====+-- > recordUpd (var "f" @@ var "x") [("a", var "b")]+--+-- > f x {a = b} -- equivalent to f (x {a = b})+-- > =====+-- > var "f" @@ recordUpd (var "x") [("a", var "b")]+recordUpd :: HsExpr' -> [(RdrNameStr, HsExpr')] -> HsExpr'+recordUpd e fs =+    withPlaceHolder4+       $ noExt RecordUpd (parenthesizeExprForApp $ builtLoc e)+       $ map mkField fs+  where+    mkField :: (RdrNameStr, HsExpr') -> LHsRecUpdField'+    mkField (f, e') =+        builtLoc HsRecField+            { hsRecFieldLbl =+                builtLoc $ withPlaceHolder $ noExt Ambiguous $ valueRdrName f+            , hsRecFieldArg = builtLoc e'+            , hsRecPun = False+            }+    withPlaceHolder4 = withPlaceHolder . withPlaceHolder . withPlaceHolder+                            . withPlaceHolder

@@ -7,14 +7,10 @@ {-# LANGUAGE CPP #-} module GHC.SourceGen.Expr.Internal where -#if MIN_VERSION_ghc(8,4,0)-import BasicTypes (IntegralLit(..))-#endif import HsExpr-import HsLit import SrcLoc (Located, unLoc) -import GHC.SourceGen.Syntax+import GHC.SourceGen.Lit.Internal import GHC.SourceGen.Syntax.Internal  parenthesizeExprForApp, parenthesizeExprForOp@@ -53,23 +49,7 @@     _ -> False needsExprForApp e = case e of     HsApp{} -> True+    HsAppType{} -> True     HsStatic{} -> True     _ -> needsExprForOp e -litNeedsParen :: HsLit' -> Bool--- For now, ignoring cases that only arrive from internal compiler passes.--- Furthermore, GHC parses primitive numbers like -3.0# without needing parentheses.--- So we can uniformly ignore this step.-litNeedsParen _ = False--overLitNeedsParen :: HsOverLit' -> Bool-overLitNeedsParen = needs . ol_val-  where-#if MIN_VERSION_ghc(8,4,0)-    needs (HsIntegral x) = il_neg x-#else-    needs (HsIntegral _ x) = x < 0-#endif-    -- GHC shows fractional values with "%", so wrap them unconditionally.-    needs HsFractional{} = True-    needs _ = False

@@ -7,11 +7,19 @@ {-# LANGUAGE CPP #-} -- | This module provides combinators for constructing Haskell literals, -- which may be used in either patterns or expressions.-module GHC.SourceGen.Lit where+module GHC.SourceGen.Lit+    ( HsLit'+    , HsOverLit'+    , HasLit(..)+    , char+    , string+    , int+    , frac+    ) where  import BasicTypes (FractionalLit(..)) #if MIN_VERSION_ghc(8,4,0)-import BasicTypes(IntegralLit(..))+import BasicTypes(IntegralLit(..), SourceText(..)) #endif import HsLit import HsExpr (noExpr, noSyntaxExpr, HsExpr(..))@@ -19,7 +27,6 @@ import FastString (fsLit)  import GHC.SourceGen.Lit.Internal-import GHC.SourceGen.Syntax import GHC.SourceGen.Syntax.Internal  class HasLit e where@@ -56,7 +63,8 @@ frac x = overLit $ withPlaceHolder $ withPlaceHolder (noExt OverLit $ HsFractional il) noExpr   where #if MIN_VERSION_ghc(8,4,0)-    il = noSourceText FL (x < 0) x+    il = FL (SourceText s) (x < 0) x #else-    il = FL (show x) x+    il = FL s x #endif+    s = show (fromRational x :: Double)

@@ -4,9 +4,33 @@ -- license that can be found in the LICENSE file or at -- https://developers.google.com/open-source/licenses/bsd +{-# LANGUAGE CPP #-} module GHC.SourceGen.Lit.Internal where -import BasicTypes (SourceText(NoSourceText))+import BasicTypes (SourceText(NoSourceText), FractionalLit(..))+#if MIN_VERSION_ghc(8,4,0)+import BasicTypes (IntegralLit(..))+#endif+import HsLit+import GHC.SourceGen.Syntax.Internal  noSourceText :: (SourceText -> a) -> a noSourceText = ($ NoSourceText)++litNeedsParen :: HsLit' -> Bool+-- For now, ignoring cases that only arrive from internal compiler passes.+-- Furthermore, GHC parses primitive numbers like -3.0# without needing parentheses.+-- So we can uniformly ignore this step.+litNeedsParen _ = False++overLitNeedsParen :: HsOverLit' -> Bool+overLitNeedsParen = needs . ol_val+  where+#if MIN_VERSION_ghc(8,4,0)+    needs (HsIntegral x) = il_neg x+    needs (HsFractional x) = fl_neg x+#else+    needs (HsIntegral _ x) = x < 0+    needs (HsFractional x) = fl_value x < 0+#endif+    needs _ = False

@@ -6,15 +6,33 @@  -- | This module provides combinators for constructing Haskell modules, -- including import and export statements.-module GHC.SourceGen.Module where+module GHC.SourceGen.Module+    ( -- * HsModule'+      HsModule'+    , module'+      -- * Import declarations+    , ImportDecl'+    , qualified'+    , as'+    , import'+    , exposing+    , hiding+      -- * Imported/exported things+    , IE'+    , thingAll+    , thingWith+    , moduleContents+    )  where +import HsImpExp (LIEWrappedName, IEWildcard(..), IEWrappedName(..), IE(..)) import HsSyn     ( HsModule(..)     , ImportDecl(..)     )+import RdrName (RdrName) -import GHC.SourceGen.Syntax import GHC.SourceGen.Syntax.Internal+import GHC.SourceGen.Name import GHC.SourceGen.Name.Internal import GHC.SourceGen.Lit.Internal (noSourceText) @@ -51,3 +69,39 @@ hiding :: ImportDecl' -> [IE'] -> ImportDecl' hiding d ies = d     { ideclHiding = Just (True, builtLoc $ map builtLoc ies) }++-- | Exports all methods and/or constructors.+--+-- > A(..)+-- > =====+-- > thingAll "A"+thingAll :: RdrNameStr -> IE'+thingAll = noExt IEThingAll . wrappedName++-- | Exports specific methods and/or constructors.+--+-- > A(b, C)+-- > =====+-- > thingWith "A" ["b", "C"]+thingWith :: RdrNameStr -> [OccNameStr] -> IE'+thingWith n cs = noExt IEThingWith (wrappedName n) NoIEWildcard+                    (map (wrappedName . unqual) cs)+                    -- The parsing step leaves the list of fields empty+                    -- and lumps them all together with the above list of+                    -- constructors.+                    []++-- TODO: support "mixed" syntax with both ".." and explicit names.++wrappedName :: RdrNameStr -> LIEWrappedName RdrName+wrappedName = builtLoc . IEName . exportRdrName++-- | Exports an entire module.+--+-- Note: this is not valid inside of an import list.+--+-- > module M+-- > =====+-- > moduleContents "M"+moduleContents :: ModuleNameStr -> IE'+moduleContents = noExt IEModuleContents . builtLoc . unModuleNameStr

@@ -7,20 +7,44 @@ -- | This module defines custom types for defining names of various -- syntax terms. ----- These types are all instances of 'Data.String.IsString'.  For easier use,+-- These types are all instances of 'Data.String.IsString'.  For ease of use, -- we recommend enabling the @OverloadedStrings@ extension. module GHC.SourceGen.Name-    ( RdrNameStr(..)-    , OccNameStr-    , ModuleNameStr(..)+    ( -- * RdrNameStr+      RdrNameStr(..)+    , RawNameSpace(..)+    , rdrNameStrToString     , qual     , unqual+      -- * OccNameStr+    , OccNameStr+    , occNameStrToString+    , occNameStrNamespace+      -- ModuleNameStr+    , ModuleNameStr(..)+    , moduleNameStrToString     ) where +import FastString (unpackFS)+import Module (moduleNameString) import GHC.SourceGen.Name.Internal  unqual :: OccNameStr -> RdrNameStr-unqual = RawUnqual+unqual = UnqualStr  qual :: ModuleNameStr -> OccNameStr -> RdrNameStr-qual = RawQual+qual = QualStr++moduleNameStrToString :: ModuleNameStr -> String+moduleNameStrToString = moduleNameString . unModuleNameStr++occNameStrToString :: OccNameStr -> String+occNameStrToString (OccNameStr _ s) = unpackFS s++occNameStrNamespace :: OccNameStr -> RawNameSpace+occNameStrNamespace (OccNameStr n _) = n++rdrNameStrToString :: RdrNameStr -> String+rdrNameStrToString (UnqualStr o) = occNameStrToString o+rdrNameStrToString (QualStr m o) =+    moduleNameStrToString m ++ '.' : occNameStrToString o

@@ -6,23 +6,36 @@  module GHC.SourceGen.Name.Internal where -import Data.Char (isUpper)+import Data.Char (isAlphaNum, isUpper)+import Data.List (intercalate) import Data.String (IsString(..)) import FastString (FastString, fsLit)-import Module (mkModuleNameFS, ModuleName)+import Module (mkModuleNameFS, ModuleName, moduleNameString) import RdrName import OccName import SrcLoc (Located)  import GHC.SourceGen.Syntax.Internal (builtLoc) --- | A string identifier.  This definition is simililar to 'RdrName', but--- independent of whether it's in the type or value namespace.+-- | A string identifier referring to a name.+--+-- 'OccNameStr' keeps track of whether it is a "constructor" or "variable"+-- (e.g.: @\"Foo\"@ vs @\"foo\"@, respectively).+--+-- 'OccNameStr' is simililar in purpose to GHC's 'OccName'.  However, unlike+-- 'OccName', 'OccNameStr' does not differentiate between the namespace+-- of types and of values.+-- Functions in this package that take an 'OccNameStr' as input+-- will internally convert it to the proper namespace.  (This approach+-- makes it easier to implement an 'IsString' instance without the context+-- where a name would be used.) data OccNameStr = OccNameStr !RawNameSpace !FastString+    deriving (Show, Eq, Ord)  data RawNameSpace = Constructor | Value--- TODO: symbols+    deriving (Show, Eq, Ord) +-- TODO: symbols rawNameSpace :: String -> RawNameSpace rawNameSpace (c:_)     | isUpper c = Constructor@@ -39,34 +52,71 @@  -- | A newtype wrapper around 'ModuleName' which is an instance of 'IsString'. newtype ModuleNameStr = ModuleNameStr { unModuleNameStr :: ModuleName }+    deriving (Eq, Ord) +instance Show ModuleNameStr where+    show = show . moduleNameString . unModuleNameStr+ instance IsString ModuleNameStr where     fromString = ModuleNameStr . mkModuleNameFS . fsLit  -- | A string identifier which may be qualified to a particular module. ----- For example:+-- 'RdrNameStr' wraps an 'OccNameStr' and thus keeps track of whether it is a+-- "constructor" or "variable" (e.g.: @\"Foo.Bar\"@ vs @\"Foo.bar\"@,+-- respectively). ----- > fromString "A.b.c" == RawQual (fromString "A.b") (fromString "c")--- > fromString "c" == RawUnqual (fromString "c")+-- 'RdrNameStr' is simililar in purpose to GHC's 'RdrName'.  However, unlike+-- 'RdrName', 'RdrNameStr' does not differentiate between the namespace of types+-- and of values.+-- Functions in this package that take a 'RdrNameStr' as input+-- will internally convert it to the proper namespace.  (This approach+-- makes it easier to implement an 'IsString' instance without the context+-- where a name would be used.) ----- This definition is simililar to 'RdrName', but independent of whether it's--- in the type or value namespace.  Functions in this package that take--- a 'RdrName' as input will internally convert it to the proper namespace.-data RdrNameStr = RawUnqual OccNameStr | RawQual ModuleNameStr OccNameStr+-- For example:+--+-- > fromString "A.B.c" == QualStr (fromString "A.B") (fromString "c")+-- > fromString "c" == UnqualStr (fromString "c")+data RdrNameStr = UnqualStr OccNameStr | QualStr ModuleNameStr OccNameStr+    deriving (Show, Eq, Ord)  -- GHC always wraps RdrName in a Located.  (Usually: 'Located (IdP pass)') -- So for convenience, these functions return a Located-wrapped value. valueRdrName, typeRdrName :: RdrNameStr -> Located RdrName-valueRdrName (RawUnqual r) = builtLoc $ Unqual $ valueOccName r-valueRdrName (RawQual (ModuleNameStr m) r) = builtLoc $ Qual m $ valueOccName r-typeRdrName (RawUnqual r) = builtLoc $ Unqual $ typeOccName r-typeRdrName (RawQual (ModuleNameStr m) r) = builtLoc $ Qual m $ typeOccName r+valueRdrName (UnqualStr r) = builtLoc $ Unqual $ valueOccName r+valueRdrName (QualStr (ModuleNameStr m) r) = builtLoc $ Qual m $ valueOccName r+typeRdrName (UnqualStr r) = builtLoc $ Unqual $ typeOccName r+typeRdrName (QualStr (ModuleNameStr m) r) = builtLoc $ Qual m $ typeOccName r  -- TODO: operators instance IsString RdrNameStr where     -- Split "Foo.Bar.baz" into ("Foo.Bar", "baz")-    fromString f = case span (/= '.') (reverse f) of-        (f', '.':f'') ->-            RawQual (fromString $ reverse f'') (fromString $ reverse f')-        _ -> RawUnqual (fromString f)+    fromString s = case collectModuleName s of+        (m, n)+            | null m -> UnqualStr (fromString n)+            | otherwise -> QualStr (fromString $ intercalate "." m) (fromString n)++collectModuleName :: String -> ([String],String)+collectModuleName s = case span isVarChar s of+    ("", n) -> ([], n)  -- Symbol+    (n, "") -> ([], n)  -- Identifier+    (m, '.' : s') -> case collectModuleName s' of+                            (m', s'') -> (m : m', s'')+    _ -> error $ "Unable to parse RdrNameStr: " ++ show s+  where+    isVarChar '\'' = True+    isVarChar '_' = True+    isVarChar c = isAlphaNum c++-- | A RdrName suitable for an import or export list.+-- E.g.: `import F(a, B)`+-- The 'a' should be a value, but the 'B' should be a type/class.+-- (Currently, GHC doesn't distinguish the class and type namespaces.)+exportRdrName :: RdrNameStr -> Located RdrName+exportRdrName (UnqualStr r) = builtLoc $ Unqual $ exportOccName r+exportRdrName (QualStr (ModuleNameStr m) r) = builtLoc $ Qual m $ exportOccName r++exportOccName :: OccNameStr -> OccName+exportOccName (OccNameStr Value s) = mkVarOccFS s+exportOccName (OccNameStr Constructor s) = mkTcOccFS s

@@ -15,6 +15,7 @@     , unboxedTuple     , HasList(..)     , Var(..)+    , BVar(..)     ) where  import BasicTypes (Boxity(..))@@ -34,13 +35,12 @@     , HsTupleSort(..)     ) import DataCon (dataConName)-import RdrName (RdrName, nameRdrName)+import RdrName (RdrName(..), nameRdrName) import SrcLoc (Located) import TysWiredIn (consDataCon_RDR, nilDataCon, unitDataCon)  import GHC.SourceGen.Expr.Internal import GHC.SourceGen.Name.Internal-import GHC.SourceGen.Syntax import GHC.SourceGen.Syntax.Internal import GHC.SourceGen.Type.Internal @@ -127,7 +127,7 @@             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@@ -136,7 +136,7 @@                 (typeRdrName o)                 (parenthesizeTypeForOp $ builtLoc y)     x @@ y = noExt HsAppTy-                (builtLoc x)+                (parenthesizeTypeForOp $ builtLoc x)                 (parenthesizeTypeForApp $ builtLoc y)  class HasTuple e where@@ -210,26 +210,43 @@     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 = noExt IEVar . builtLoc . IEName . valueRdrName+    var n = noExt IEVar $ builtLoc $ IEName $ exportRdrName n++instance BVar IE' where+    bvar = var . UnqualStr+

@@ -4,15 +4,27 @@ -- 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 where+module GHC.SourceGen.Pat+    ( Pat'+    , wildP+    , asP+    , conP+    , conP_+    , recordConP+    , strictP+    , lazyP+    , sigP+    ) where  import HsTypes-import HsPat+import HsPat hiding (LHsRecField')  import GHC.SourceGen.Name.Internal-import GHC.SourceGen.Syntax+import GHC.SourceGen.Pat.Internal import GHC.SourceGen.Syntax.Internal+import GHC.SourceGen.Type.Internal (sigWcType)  -- | A wild pattern (@_@). wildP :: Pat'@@ -24,28 +36,65 @@ -- > ===== -- > 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. -- -- > 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 xs+conP c xs = ConPatIn (valueRdrName c) $ PrefixCon+                $ map (builtPat . parenthesize) xs +-- | A pattern constructor with no arguments.+--+-- > A+-- > =====+-- > conP_ "A"+conP_ :: RdrNameStr -> Pat'+conP_ c = conP c []++recordConP :: RdrNameStr -> [(RdrNameStr, Pat')] -> Pat'+recordConP c fs+    = ConPatIn (valueRdrName c)+        $ RecCon $ HsRecFields (map mkRecField fs) Nothing -- No ".."+  where+    mkRecField :: (RdrNameStr, Pat') -> LHsRecField' LPat'+    mkRecField (f, p) =+        builtLoc $ HsRecField+            { hsRecFieldLbl =+                builtLoc $ withPlaceHolder $ noExt FieldOcc $ valueRdrName f+            , hsRecFieldArg = builtPat p+            , hsRecPun = False+            }+ -- | A bang-pattern. -- -- > !x -- > =====--- > strictP (var x)+-- > strictP (bvar x) strictP :: Pat' -> Pat'-strictP = noExt BangPat . builtPat+strictP = noExt BangPat . builtPat . parenthesize  -- | A lazy pattern match. -- -- > ~(A x) -- > =====--- > lazyP (conP "A" [var x])+-- > lazyP (conP "A" [bvar x]) lazyP :: Pat' -> Pat'-lazyP = noExt LazyPat . builtPat+lazyP = noExt LazyPat . builtPat . parenthesize++-- | A pattern type signature+--+-- > x :: 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)+#elif MIN_VERSION_ghc(8,6,0)+sigP p t = SigPat (sigWcType t) (builtPat p)+#else+sigP p t = SigPatIn (builtPat p) (sigWcType t)+#endif

@@ -0,0 +1,40 @@+{-# LANGUAGE CPP #-}+module GHC.SourceGen.Pat.Internal where++import HsPat (Pat(..))+import HsTypes (HsConDetails(..))++import GHC.SourceGen.Lit.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+

@@ -1,109 +0,0 @@--- Copyright 2019 Google LLC------ Use of this source code is governed by a BSD-style--- license that can be found in the LICENSE file or at--- https://developers.google.com/open-source/licenses/bsd--{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{- | This module defines type synonyms for the different parts of GHC's syntax-tree.--GHC uses the same types at different stages of the compilation, distinguishing-them using a type parameter.-The functions in @ghc-source-gen@ construct values as they would appear after the-parsing step.--}-module GHC.SourceGen.Syntax where--import HsSyn-    ( HsDecl-    , HsExpr(..)-    , HsLit-    , HsModule-    , HsType(..)-    , HsBind-    , HsTyVarBndr-    , HsOverLit-    , HsValBinds-    , HsMatchContext-    , IE-    , LHsQTyVars-    , Match-    , MatchGroup-    , GRHS-    , GRHSs-    , Stmt-    , ConDecl-    , HsConDeclDetails-    , LHsSigType-    , ImportDecl-    , LHsSigWcType-    , LHsWcType-    )-import HsBinds (Sig, HsLocalBinds)-import HsPat-import RdrName (RdrName)-import SrcLoc (Located)--#if MIN_VERSION_ghc(8,4,0)-import HsExtension (GhcPs)-#endif--#if MIN_VERSION_ghc(8,4,0)-type HsExpr' = HsExpr GhcPs-type HsLit' = HsLit GhcPs-type HsType' = HsType GhcPs-type HsDecl' = HsDecl GhcPs-type HsModule' = HsModule GhcPs-type HsBind' = HsBind GhcPs-type HsLocalBinds' = HsLocalBinds GhcPs-type HsValBinds' = HsValBinds GhcPs-type Sig' = Sig GhcPs-type Pat' = Pat GhcPs-type HsMatchContext' = HsMatchContext RdrName-type Match' = Match GhcPs-type MatchGroup' = MatchGroup GhcPs-type GRHS' = GRHS GhcPs-type GRHSs' = GRHSs GhcPs-type Stmt' = Stmt GhcPs (Located HsExpr')-type HsTyVarBndr' = HsTyVarBndr GhcPs-type HsOverLit' = HsOverLit GhcPs-type LHsQTyVars' = LHsQTyVars GhcPs-type ConDecl' = ConDecl GhcPs-type HsConDeclDetails' = HsConDeclDetails GhcPs-type LHsSigType' = LHsSigType GhcPs-type IE' = IE GhcPs-type ImportDecl' = ImportDecl GhcPs-type LHsSigWcType' = LHsSigWcType GhcPs-type LHsWcType' = LHsWcType GhcPs--#else-type HsExpr' = HsExpr RdrName-type HsLit' = HsLit-type HsType' = HsType RdrName-type HsDecl' = HsDecl RdrName-type HsModule' = HsModule RdrName-type HsBind' = HsBind RdrName-type HsLocalBinds' = HsLocalBinds RdrName-type HsValBinds' = HsValBinds RdrName-type Sig' = Sig RdrName-type Pat' = Pat RdrName-type HsMatchContext' = HsMatchContext RdrName-type Match' = Match RdrName-type MatchGroup' = MatchGroup RdrName-type GRHS' = GRHS RdrName-type GRHSs' = GRHSs RdrName-type Stmt' = Stmt RdrName (Located HsExpr')-type HsTyVarBndr' = HsTyVarBndr RdrName-type HsOverLit' = HsOverLit RdrName-type LHsQTyVars' = LHsQTyVars RdrName-type ConDecl' = ConDecl RdrName-type HsConDeclDetails' = HsConDeclDetails RdrName-type LHsSigType' = LHsSigType RdrName-type IE' = IE RdrName-type ImportDecl' = ImportDecl RdrName-type LHsSigWcType' = LHsSigWcType RdrName-type LHsWcType' = LHsWcType RdrName--#endif

@@ -8,6 +8,47 @@ {-# LANGUAGE OverloadedStrings #-} module GHC.SourceGen.Syntax.Internal where ++import HsSyn+    ( HsDecl+    , HsExpr(..)+    , HsLit+    , HsModule+    , HsType(..)+    , HsBind+    , HsTyVarBndr+    , HsOverLit+    , HsValBinds+    , HsMatchContext+    , IE+    , LHsQTyVars+    , Match+    , MatchGroup+    , GRHS+    , GRHSs+    , Stmt+    , ConDecl+    , HsConDeclDetails+    , LHsSigType+    , ImportDecl+    , LHsSigWcType+    , LHsWcType+    , HsImplicitBndrs+    , TyFamInstDecl+#if !MIN_VERSION_ghc(8,8,0)+    , LHsRecField+    , LHsRecUpdField+#endif+    )+import HsBinds (Sig, HsLocalBinds)+#if MIN_VERSION_ghc(8,6,0)+import HsDecls (DerivStrategy)+#else+import BasicTypes (DerivStrategy)+#endif+import HsDecls (HsDerivingClause)+import HsPat+import RdrName (RdrName) import SrcLoc (SrcSpan, Located, GenLocated(..), mkGeneralSrcSpan)  #if MIN_VERSION_ghc(8,8,0)@@ -21,8 +62,11 @@ #else import PlaceHolder(PlaceHolder(..)) #endif-import GHC.SourceGen.Syntax +#if MIN_VERSION_ghc(8,4,0)+import HsExtension (GhcPs)+#endif+ #if MIN_VERSION_ghc(8,6,0) noExt :: (NoExt -> a) -> a noExt = ($ NoExt)@@ -54,11 +98,10 @@  -- In GHC-8.8, source locations for Pat aren't stored in each node, and -- LPat is a synonym for Pat.+builtPat :: Pat' -> LPat' #if MIN_VERSION_ghc(8,8,0)-builtPat :: Pat' -> Pat' builtPat = id #else-builtPat :: Pat' -> Located Pat' builtPat = builtLoc #endif @@ -70,4 +113,155 @@ promoted, notPromoted :: Promoted promoted = Promoted notPromoted = NotPromoted+#endif++-- TODO: these Haddock cross-references don't link to the actual+-- definition, only to the module they come from.  I think it's+-- because the classes aren't in scope here.++-- | A Haskell type, as it is represented after the parsing step.+--+-- Instances:+--+-- * 'GHC.SourceGen.Overloaded.BVar'+-- * 'GHC.SourceGen.Overloaded.Var'+-- * 'GHC.SourceGen.Overloaded.Par'+-- * 'GHC.SourceGen.Overloaded.App'+-- * 'GHC.SourceGen.Overloaded.HasTuple'+#if MIN_VERSION_ghc(8,4,0)+type HsType' = HsType GhcPs+#else+type HsType' = HsType RdrName+#endif++-- | A Haskell pattern, as it is represented after the parsing step.+--+-- Instances:+--+-- * 'GHC.SourceGen.Overloaded.BVar'+-- * 'GHC.SourceGen.Overloaded.Par'+-- * 'GHC.SourceGen.Overloaded.HasTuple'+-- * 'GHC.SourceGen.Overloaded.HasList'+-- * 'GHC.SourceGen.Lit.HasLit'+#if MIN_VERSION_ghc(8,4,0)+type Pat' = Pat GhcPs+#else+type Pat' = Pat RdrName+#endif++-- | A Haskell expression, as it is represented after the parsing step.+--+-- Instances:+--+-- * 'GHC.SourceGen.Overloaded.BVar'+-- * 'GHC.SourceGen.Overloaded.Var'+-- * 'GHC.SourceGen.Overloaded.Par'+-- * 'GHC.SourceGen.Overloaded.App'+-- * 'GHC.SourceGen.Overloaded.HasTuple'+-- * 'GHC.SourceGen.Overloaded.HasList'+-- * 'GHC.SourceGen.Lit.HasLit'+#if MIN_VERSION_ghc(8,4,0)+type HsExpr' = HsExpr GhcPs+#else+type HsExpr' = HsExpr RdrName+#endif++-- | A Haskell declaration, as it is represented after the parsing step.+--+-- Instances:+--+-- * 'GHC.SourceGen.Binds.HasValBind'+-- * 'GHC.SourceGen.Binds.HasPatBind'+#if MIN_VERSION_ghc(8,4,0)+type HsDecl' = HsDecl GhcPs+#else+type HsDecl' = HsDecl RdrName+#endif++-- | An imported or exported entity, as it is represented after the parsing step.+--+-- Instances:+--+-- * 'GHC.SourceGen.Overloaded.BVar'+-- * 'GHC.SourceGen.Overloaded.Var'+#if MIN_VERSION_ghc(8,4,0)+type IE' = IE GhcPs+#else+type IE' = IE RdrName+#endif+++-- | A type variable binding, as it is represented after the parsing step.+--+-- Instances:+--+-- * 'GHC.SourceGen.Overloaded.BVar'+#if MIN_VERSION_ghc(8,4,0)+type HsTyVarBndr' = HsTyVarBndr GhcPs+#else+type HsTyVarBndr' = HsTyVarBndr RdrName+#endif++#if MIN_VERSION_ghc(8,4,0)+type HsLit' = HsLit GhcPs+type HsModule' = HsModule GhcPs+type HsBind' = HsBind GhcPs+type HsLocalBinds' = HsLocalBinds GhcPs+type HsValBinds' = HsValBinds GhcPs+type Sig' = Sig GhcPs+type HsMatchContext' = HsMatchContext RdrName+type Match' = Match GhcPs+type MatchGroup' = MatchGroup GhcPs+type GRHS' = GRHS GhcPs+type GRHSs' = GRHSs GhcPs+type Stmt' = Stmt GhcPs (Located HsExpr')+type HsOverLit' = HsOverLit GhcPs+type LHsQTyVars' = LHsQTyVars GhcPs+type ConDecl' = ConDecl GhcPs+type HsConDeclDetails' = HsConDeclDetails GhcPs+type LHsSigType' = LHsSigType GhcPs+type ImportDecl' = ImportDecl GhcPs+type LHsSigWcType' = LHsSigWcType GhcPs+type LHsWcType' = LHsWcType GhcPs+type HsDerivingClause' = HsDerivingClause GhcPs+type LHsRecField' arg = LHsRecField GhcPs arg+type LHsRecUpdField' = LHsRecUpdField GhcPs+type LPat' = LPat GhcPs+type HsImplicitBndrs' = HsImplicitBndrs GhcPs+type TyFamInstDecl' = TyFamInstDecl GhcPs++#else+type HsLit' = HsLit+type HsModule' = HsModule RdrName+type HsBind' = HsBind RdrName+type HsLocalBinds' = HsLocalBinds RdrName+type HsValBinds' = HsValBinds RdrName+type Sig' = Sig RdrName+type HsMatchContext' = HsMatchContext RdrName+type Match' = Match RdrName+type MatchGroup' = MatchGroup RdrName+type GRHS' = GRHS RdrName+type GRHSs' = GRHSs RdrName+type Stmt' = Stmt RdrName (Located HsExpr')+type HsOverLit' = HsOverLit RdrName+type LHsQTyVars' = LHsQTyVars RdrName+type ConDecl' = ConDecl RdrName+type HsConDeclDetails' = HsConDeclDetails RdrName+type LHsSigType' = LHsSigType RdrName+type ImportDecl' = ImportDecl RdrName+type LHsSigWcType' = LHsSigWcType RdrName+type LHsWcType' = LHsWcType RdrName+type HsDerivingClause' = HsDerivingClause RdrName+type LHsRecField' arg = LHsRecField RdrName arg+type LHsRecUpdField' = LHsRecUpdField RdrName+type LPat' = LPat RdrName+type HsImplicitBndrs' = HsImplicitBndrs RdrName+type TyFamInstDecl' = TyFamInstDecl RdrName++#endif++#if MIN_VERSION_ghc(8,6,0)+type DerivStrategy' = DerivStrategy GhcPs+#else+type DerivStrategy' = DerivStrategy #endif

@@ -5,12 +5,22 @@ -- https://developers.google.com/open-source/licenses/bsd  -- | This module provides combinators for constructing Haskell types.-module GHC.SourceGen.Type where+module GHC.SourceGen.Type+    ( HsType'+    , tyPromotedVar+    , stringTy+    , numTy+    , listTy+    , listPromotedTy+    , (-->)+    , forall'+    , HsTyVarBndr'+    , (==>)+    ) where  import Data.String (fromString) import HsTypes -import GHC.SourceGen.Syntax import GHC.SourceGen.Syntax.Internal import GHC.SourceGen.Lit.Internal (noSourceText) import GHC.SourceGen.Name.Internal@@ -18,7 +28,7 @@  -- | A promoted name, for example from the @DataKinds@ extension. tyPromotedVar :: RdrNameStr -> HsType'-tyPromotedVar = noExt HsTyVar notPromoted . typeRdrName+tyPromotedVar = noExt HsTyVar promoted . typeRdrName  stringTy :: String -> HsType' stringTy = noExt HsTyLit . noSourceText HsStrTy . fromString@@ -42,6 +52,11 @@  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 @@ -52,3 +67,5 @@ -- > [var "F" @@ var "x", var "G" @@ var "x"] ==> var "x" (==>) :: [HsType'] -> HsType' -> HsType' (==>) cs = noExt HsQualTy (builtLoc (map builtLoc cs)) . builtLoc++infixr 0 ==>

@@ -10,18 +10,20 @@ import HsTypes import SrcLoc (Located, unLoc) -import GHC.SourceGen.Syntax 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'-sigType t = withPlaceHolder $ noExt (withPlaceHolder HsTypes.HsIB) $ builtLoc t+sigType = implicitBndrs . builtLoc++implicitBndrs :: t -> HsImplicitBndrs' t+implicitBndrs = withPlaceHolder . noExt (withPlaceHolder HsTypes.HsIB)   -- TODO: GHC >= 8.6 provides parenthesizeHsType.  For consistency with

@@ -0,0 +1,16 @@+-- A module for changing behavior based on the version of GHC.+{-# LANGUAGE CPP #-}+module GhcVersion where++import Data.Version+import Text.ParserCombinators.ReadP++ghcVersion :: Version+ghcVersion = case readP_to_S (parseVersion <* eof) VERSION_ghc of+    [(v,"")] -> v+    _ -> error $ "Unable to parse GHC version " ++ show VERSION_ghc++ifGhc88 :: a -> a -> a+ifGhc88 x y = if makeVersion [8,8] <= ghcVersion+                then x+                else y

@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import GHC.SourceGen.Name++import Data.List (intercalate)+import Data.String (fromString)+import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.HUnit++main :: IO ()+main = defaultMain $ testGroup "Tests" [testOccName, testRdrName]++testRdrName, testOccName :: TestTree+testRdrName = testGroup "RdrName"+    [ testCase "unqual ident" $ do+        UnqualStr "abc" @=? "abc"+    , testCase "qual ident" $ do+        QualStr "Foo" "abc" @=? "Foo.abc"+    , testCase "hierarchical qual ident" $ do+        QualStr "Foo.Bar" "abc" @=? "Foo.Bar.abc"+    , testCase "unqual op" $ do+        UnqualStr "+-+" @=? "+-+"+    , testCase "qual op" $ do+        QualStr "Foo" "+-+" @=? "Foo.+-+"+    , testCase "hierarchical qual op" $ do+        QualStr "Foo.Bar" "+-+" @=? "Foo.Bar.+-+"+    , testProperty "round tip" $ forAll genRdrName $ \r ->+        fromString (rdrNameStrToString r) === r+    ]++testOccName = testGroup "OccName"+    [ testProperty "toString" $ forAll genOccNameString $ \n ->+        occNameStrToString (fromString n) == n+    , testProperty "round-trip" $ forAll genOccName $ \o ->+        fromString (occNameStrToString o) === o+    , testProperty "constructor" $ forAll genUpperName $ \n ->+        occNameStrNamespace (fromString n) === Constructor+    , testProperty "value" $ forAll genLowerName $ \n ->+        occNameStrNamespace (fromString n) === Value+    , testProperty "punctuation" $ forAll genOp $ \n ->+        occNameStrNamespace (fromString n) === Value+    ]++genUpperName, genLowerName, genOp :: Gen String+genUpperName = (:) <$> genUpper <*> listOf genRest+genLowerName = (:) <$> genLower <*> listOf genRest+genOp = listOf1 $ genPunctuation++genUpper, genLower, genRest, genPunctuation :: Gen Char+genUpper = elements "ABC"+genLower = elements "ab1_'"+genRest = elements "Ab1_'"+genPunctuation = elements ".-+"++genOccName :: Gen OccNameStr+genOccName = fromString <$> genOccNameString++genOccNameString :: Gen String+genOccNameString = oneof [genUpperName, genLowerName, genOp]++genModuleName :: Gen ModuleNameStr+genModuleName = fromString . intercalate "." <$> listOf1 genUpperName++genRdrName :: Gen RdrNameStr+genRdrName = oneof+    [ QualStr <$> genModuleName <*> genOccName+    , UnqualStr <$> genOccName+    ]

@@ -30,7 +30,7 @@     , char 'g'     , let' [ typeSig "result" $ var "A" @@ var "B"            , funBind "result"-                $ matchRhs [var "x", wildP]+                $ match [bvar "x", wildP]                     $ var "foo" @@ char 'c'            ]         (var "result")@@ -40,75 +40,75 @@ 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 [bvar "x", bvar "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 [bvar "y"]+                    $ lambdaCase [match [bvar "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 [bvar "x"] $ if' (var "b") (var "t") (var "f")+        , match [bvar "y"] $ multiIf [guard (var "False") $ char 'f'                                        , guard (var "True") $ char 't'                                        ]-        , matchRhs [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'"-        $ matchRhs [] (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"-        $ matchRhs [tuple [var "x", var "y"]]+        $ match [tuple [bvar "x", bvar "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 [bvar "y", bvar "z"])]             (var "x")     , funBind "con"-        $ matchRhs [conP "A" [var "b", conP "C" [var "d"]]]+        $ match [conP "A" [bvar "b", conP "C" [bvar "d"]]]             $ tuple [var "b", var "d"]     , funBind "ops"-        $ matchRhs [var "x", var "y"]+        $ match [bvar "x", bvar "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 @@                                  (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"]@@ -134,10 +134,12 @@         [ prefixCon "A" [field (var "b"), field (var "c")]         , prefixCon "D" []         ]+        [deriving' [var "X", var "Y"]]     , newtype' "A" ["b", "c"] (prefixCon "A" [field (var "b")])+        [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'@@ -147,14 +149,14 @@            [ typeSig "divMod" $ a --> a --> tuple [a, a]            , typeSig "div" $ a --> a --> a            , funBind "div"-               $ matchRhs [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"-            [ matchRhs [var "True"] $ string "True"-            , matchRhs [var "False"] $ string "False"+            [ match [conP "True" []] $ string "True"+            , match [conP "False" []] $ string "False"             ]         ]     , data' "X" ["b"]@@ -187,13 +189,14 @@             , ("y", lazy $ field $ var "A" @@ var "b")             ]         ]+        []     , funBind "strictness"-        $ matchRhs-            [strictP (conP "A" [var "b"]),-             lazyP (conP "A" [var "b"])+        $ match+            [strictP (conP "A" [bvar "b"]),+             lazyP (conP "A" [bvar "b"])             ] (char 'x')     , typeSig "unit" $ unit --> unit-    , funBind "unit" $ matchRhs [unit] unit+    , funBind "unit" $ match [unit] unit     ]  test4 :: IO ()@@ -202,7 +205,11 @@ test5 :: IO () test5 = pprint $ module' (Just "M") (Just exports) imports []   where-    exports = [var "a", var "b"]+    exports = [ var "a"+              , var "A"+              , thingAll "B"+              , thingWith "C" ["d", "E"]+              ]     imports = [ qualified' $ import' "A"               , import' "B" `as'` "C"               , import' "D" `exposing` [var "d"]@@ -212,9 +219,9 @@ 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"-    b = var "b"-    x = var "x"+    a = bvar "a"+    b = bvar "b"+    x = bvar "x"

@@ -11,15 +11,17 @@ import Test.Tasty.HUnit  import GHC.SourceGen+import GhcVersion  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 +32,17 @@ 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 +55,8 @@         [ "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,15 +65,27 @@         [ "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"         , "a -> b -> c" :~ var "a" --> var "b" --> var "c"         , "a -> b -> c" :~ var "a" --> (var "b" --> var "c")         , "(a -> b) -> c" :~ (var "a" --> var "b") --> var "c"+        -- These tests also check that ==> and --> have compatible precedences:+        , "A a => a -> b" :~ [var "A" @@ var "a"] ==> var "a" --> var "b"+        , "(A a, B b) => a -> b" :~+            [var "A" @@ var "a", var "B" @@ var "b"] ==> var "a" --> var "b"+        -- It appears to be correct to *not* wrap `A => c` in parentheses;+        -- GHC still parses it as a function between two HsQualTy.+        , "(A => b) -> A => c" :~+            ([var "A"] ==> var "b") --> ([var "A"] ==> var "c")+        , "(A => b) -> A => c" :~+            ([var "A"] ==> var "b") --> [var "A"] ==> var "c"         ]     , test "literals"         [ "\"abc\"" :~ stringTy "abc"@@ -79,6 +99,11 @@         , "[x]" :~ listPromotedTy [var "x"]         , "[y, z]" :~ listPromotedTy [var "y", var "z"]         ]+    , test "tyPromotedVar"+        -- For some reason, older GHC pretty-printed an extra space.+        [ ifGhc88 "'Abc" " 'Abc" :~ tyPromotedVar "Abc"+        , ifGhc88 "T 'Abc" "T  'Abc" :~ var "T" @@ tyPromotedVar "Abc"+        ]     ]   where     test = testTypes dflags@@ -94,25 +119,45 @@     , test "app"         [ "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"         , "A 3" :~ var "A" @@ int 3         , "A (-3)" :~ var "A" @@ int (-3)-        , "A (3 % 1)" :~ var "A" @@ frac 3.0-        , "A ((-3) % 1)" :~ var "A" @@ frac (-3.0)+        , "A 3.0" :~ var "A" @@ frac 3.0+        , "A (-3.0)" :~ var "A" @@ frac (-3.0)         , "A 'x'" :~ var "A" @@ char 'x'         , "A \"xyz\"" :~ var "A" @@ string "xyz"+        , "(\\ x -> x) (\\ x -> 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"))         ]     , 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 [bvar "x"] (var "x")+            in op f "." f+        , "x @s + y @t" :~+                op (var "x" `tyApp` var "s") "+" (var "y" `tyApp` var "t")         ]+    , test "period-op"+        [ "(Prelude..) x" :~ var "Prelude.." @@ var "x"+        , "x Prelude.. y" :~ op (var "x") "Prelude.." (var "y")+        ]     , test ":@@:"         -- TODO: GHC puts extra space here.         [ "  e :: t" :~ var "e" @::@ var "t" ]@@ -132,45 +177,150 @@         , "x @a b" :~ tyApp (var "x") (var "a") @@ var "b"         , "x @(a b)" :~ tyApp (var "x") (var "a" @@ var "b")         , "x @(a + b)" :~ tyApp (var "x") (op (var "a") "+" (var "b"))+        , "f x @t" :~ (var "f" @@ var "x") `tyApp` var "t"+        , "f (x @t)" :~ var "f" @@ (var "x" `tyApp` var "t")         ]+    , test "recordConE"+        [ "A {}" :~ recordConE "A" []+        , "A {x = 1, y = 2}" :~ recordConE "A" [("x", int 1), ("y", int 2)]+        ]+    , test "recordUpd"+        [ "r {b = x, c = y}"+            :~ recordUpd (var "r") [("b", var "x"), ("c", var "y")]+        , "(f x) {b = x}"+            :~ recordUpd (var "f" @@ var "x") [("b", var "x")]+        , "f x {b = x}"+            :~ var "f" @@ recordUpd (var "x") [("b", var "x")]+        , "(x + y) {b = x}"+            :~ recordUpd (op (var "x") "+" (var "y")) [("b", var "x")]+        , "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 [bvar "x"] $ int 1] (var "f")+        , "let f (A x) = 1 in f" :~+            let' [ funBind "f" $ match [conP "A" [bvar "x"]] $ int 1] (var "f")+        ]+    , test "do"+        -- TODO: add more tests.+        [ "do (let x = 1 in x)" :~ do' [stmt $ let' [valBind "x" (int 1)] (var "x")]+        ]     ]   where     test = testExprs dflags  declsTest dflags = testGroup "Decls"     [ test "patBind"-        [ "x = x" :~ patBind (var "x") (rhs $ var "x")-        , "(x, y) = (y, x)" :~ patBind (tuple [var "x", var "y"])-                                    (rhs $ tuple [var "y", var "x"])+        [ "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)" :~-            patBind (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 = ()" :~-            patBind (var "z")+            patBindGRHSs (bvar "z")                 $ guardedRhs                     [guards-                        [ conP "Just" [var "y"] <-- var "x"+                        [ conP "Just" [bvar "y"] <-- var "x"                         , stmt (var "y")                         ]                         unit                     ]         ]+    , test "valBind"+        [ "x = y" :~ valBindGRHSs "x" $ rhs $ var "y"+        , "x = y" :~ valBind "x" $ var "y"+        , "x | test = 1\n  | otherwise = 2" :~+            valBindGRHSs "x"+            $ guardedRhs+                [ var "test" `guard` int 1+                , var "otherwise" `guard` int 2+                ]+        , "x = (+)" :~ valBind "x" $ var "+"+        ]     , test "funBind"         [ "not True = False\nnot False = True" :~              funBinds "not"-                [ matchRhs [var "True"] (var "False")-                , matchRhs [var "False"] (var "True")+                [ match [bvar "True"] (var "False")+                , match [bvar "False"] (var "True")                 ]         , "not x\n  | x = False\n  | otherwise = True" :~             funBind "not"-                $ match [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" [bvar "x"]] (int 1)         ]+    , test "tyFamInst"+        [ "type instance Elt String = Char"+            :~ tyFamInst "Elt" [var "String"] (var "Char")+        , "instance Container String where\n  type Elt String = Char"+            :~ instance' (var "Container" @@ var "String")+                [tyFamInst "Elt" [var "String"] (var "Char")]+        ]+    , test "patSynSigs"+        [ "pattern F, G :: T" :~ patSynSigs ["F", "G"] $ var "T"+        , "pattern F :: T" :~ patSynSig "F" $ var "T"+        ]+    , test "patSynBind"+        [ "pattern F a b = G b a"+            :~ patSynBind "F" ["a", "b"] $ conP "G" [bvar "b", bvar "a"]+        ]     ]   where     test = testDecls dflags++patsTest dflags = testGroup "Pats"+    [ test "app"+        [ "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" [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]+        , "A (-3.0)" :~ conP "A" [frac (-3.0)]+        , "A 'x'" :~ conP "A" [char 'x']+        , "A \"xyz\"" :~ conP "A" [string "xyz"]+        , "A B {x = C}"+            :~ conP "A" [recordConP "B" [("x", conP "C" [])]]+        ]+    , test "asP"+        [ "x@B" :~ asP "x" $ conP "B" []+        , "x@(B y)" :~ asP "x" $ conP "B" [bvar "y"]+        , "x@_" :~ asP "x" wildP+        ]+    , test "strictP"+        [ "!x" :~ strictP $ bvar "x"+        , "!B" :~ strictP $ conP "B" []+        , "!(B y)" :~ strictP $ conP "B" [bvar "y"]+        , "!_" :~ strictP wildP+        ]+    , test "lazyP"+        [ "~x" :~ lazyP $ bvar "x"+        , "~B" :~ lazyP $ conP "B" []+        , "~(B y)" :~ lazyP $ conP "B" [bvar "y"]+        , "~_" :~ lazyP wildP+        ]+    , test "sigPat"+        [ "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" [])]+        ]+    ]+  where+    test = testPats dflags+