ghc-source-gen (empty) → 0.1.0.0

raw patch · 25 files changed

+2404/−0 lines, 25 filesdep +basedep +ghcdep +ghc-pathssetup-changed

Dependencies added: base, ghc, ghc-paths, ghc-source-gen, tasty, tasty-hunit

Files

• ChangeLog.md +3/−0
• LICENSE +28/−0
• README.md +150/−0
• Setup.hs +8/−0
• ghc-source-gen.cabal +95/−0
• src/GHC/SourceGen.hs +45/−0
• src/GHC/SourceGen/Binds.hs +223/−0
• src/GHC/SourceGen/Binds/Internal.hs +103/−0
• src/GHC/SourceGen/Decl.hs +338/−0
• src/GHC/SourceGen/Expr.hs +104/−0
• src/GHC/SourceGen/Expr/Internal.hs +75/−0
• src/GHC/SourceGen/Lit.hs +62/−0
• src/GHC/SourceGen/Lit/Internal.hs +12/−0
• src/GHC/SourceGen/Module.hs +53/−0
• src/GHC/SourceGen/Name.hs +26/−0
• src/GHC/SourceGen/Name/Internal.hs +72/−0
• src/GHC/SourceGen/Overloaded.hs +235/−0
• src/GHC/SourceGen/Pat.hs +51/−0
• src/GHC/SourceGen/Pretty.hs +25/−0
• src/GHC/SourceGen/Syntax.hs +109/−0
• src/GHC/SourceGen/Syntax/Internal.hs +73/−0
• src/GHC/SourceGen/Type.hs +54/−0
• src/GHC/SourceGen/Type/Internal.hs +64/−0
• tests/pprint_examples.hs +220/−0
• tests/pprint_test.hs +176/−0

@@ -0,0 +1,3 @@+# Changelog for haskell-syntax++## Unreleased changes

@@ -0,0 +1,28 @@+Copyright 2019 Google LLC++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++   * Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer.+   * Redistributions in binary form must reproduce the above+copyright notice, this list of conditions and the following disclaimer+in the documentation and/or other materials provided with the+distribution.++   * Neither the name of Google LLC nor the names of its+contributors may be used to endorse or promote products derived from+this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,150 @@+# 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+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+`GHC.SourceGen` module.++This package is not an officially supported Google product.++[library API]: https://hackage.haskell.org/package/ghc++## Example++The following example creates a module that defines the+`const` function:++```haskell+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+import GHC.SourceGen+import GHC.Paths (libdir)++constModule :: HsModule'+constModule =+    module' (Just "Const") (Just [var "const"]) []+        [ typeSig "const" $ a --> b --> a+        , funBind "const" $ matchRhs [wildP, x] x+        ]+  where+    a = var "a"+    b = var "b"+    x = var "x"++main = runGhc (Just libdir) $ putPpr constModule+```++The output of that program is:++```+module Const (+        const+    ) where+const :: a -> b -> a+const _ x = x+```++## Comparison with the GHC API++The raw GHC API has several complexities that `ghc-source-gen` simplifies for the+purpose of source code generation.++### Backwards-compatibility+`ghc-source-gen` provides the same API across several versions of GHC.  Code written+with `ghc-source-gen` should compile unchanged on each of those versions.++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+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.++### Less verbose types and construction functions++The datatypes that GHC uses to represent Haskell syntax change their+representation at different stages of the compilation: for example, parsing,+renaming, or type-checking.  That data transformation provides type safety and+a uniform structure across the phases.  However, it also adds unnecessary+complexity to the task of source code generation.++`ghc-source-gen` aims to provide a simple interface by creating data types as+GHC would represent them immediately after its *parsing* step.  For example,+`ghc >= 8.4` uses a type parameter `p` in its syntax types: `HsExpr p` for+expressions, `HsDecl p` for declarations, etc.  `ghc-source-gen` defines type+synonyms for them:++```haskell+type HsExpr' = HsExpr GhcPs+type HsDecl' = HsDecl GhcPs+type HsType' = HsType GhcPs+-- etc.+```++Furthermore, most constructors take an extra "extension" field which can+contain different information in different stages, influenced by the parameter+`p`.  In almost all cases, after the parsing step that field is the+trivial type `data NoExt = NoExt`.  (For more details, see the [Trees that+Grow] paper. GHC versions earlier than 8.4 used a similar `PlaceHolder` type.).+This extra data makes code generation more verbose.++`ghc-source-gen` automatically sets the `NoExt` value (or equivalent) for the+terms that it generates, hiding that detail from its external API.  It also+sets and hides other fields that are irrelevant to parsing or pretty-printing,+such as simplifier ticks.++[Trees that Grow]: https://gitlab.haskell.org/ghc/ghc/wikis/implementing-trees-that-grow++### Source Locations+GHC carefully tracks the source location of (nearly) every node in the AST.+That information is very useful for error reporting.  However, it would be too+verbose to set it explicitly for each individual node during code generation.+Furthermore, GHC doesn't use the source location when pretty-printing its+output, which is `ghc-source-gen`'s main use case.++Currently, `ghc-source-gen` gives to each node it generates a trivial location+without an explicit line or column.++### Parentheses+GHC represents parentheses explicitly in its syntax tree, so that it can print code+exactly as it was parsed.  Unfortunately, this means that its pretty-printing code+expects those parentheses to be present, and outputs incorrect+source code if they are missing.  `ghc-source-gen`+adds parentheses automatically in the code that it generates.++For example, consider a simplified expression syntax:++```haskell+data Expr+    = VarE String      -- ^ Variables+    | App Expr Expr    -- ^ Function application+    | Paren Expr Expr  -- ^ Parentheses+```++Then GHC would pretty-print as `"f (g x)"` the tree++```haskell+App (VarE "f") $ Paren $ App (VarE "g") (VarE "h")+```++But without the explicit parenthesis, it would pretty-print as `"f g x"`:++```haskell+App (VarE "f") $ App (VarE "g") (VarE "h")+```++which misrepresents the precedence between the two function applications.++`ghc-source-gen` resolves this issue by inserting parentheses automatically, and only when necessary.  In the expression++```haskell+var "f" @@ (var "g" @@ var "h")+```++it inserts a parenthesis automatically so that the result pretty-prints to `"f (g x)"` as expected.++GHC uses a similar approach internally itself.  For more discussion, see tickets [14289](https://gitlab.haskell.org/ghc/ghc/issues/14289) and [15738](https://gitlab.haskell.org/ghc/ghc/issues/15738).

@@ -0,0 +1,8 @@+-- 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++import Distribution.Simple+main = defaultMain

@@ -0,0 +1,95 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: bbf81e9b932cf501a87fab8a5ebcea3df292f1cab234cad74fb08185047e9388++name:           ghc-source-gen+version:        0.1.0.0+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+                to support recent language extensions, and provides a simple, consistent+                interface across several major versions of GHC.+                .+                To get started, take a look at the "GHC.SourceGen" module.+                .+                For more information, please see the <https://github.com/google/ghc-source-gen README>.+category:       Development+homepage:       https://github.com/google/ghc-source-gen#readme+bug-reports:    https://github.com/google/ghc-source-gen/issues+author:         Judah Jacobson+maintainer:     judahjacobson@google.com+copyright:      Google LLC+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10+extra-source-files:+    ChangeLog.md+    README.md++source-repository head+  type: git+  location: https://github.com/google/ghc-source-gen++library+  exposed-modules:+      GHC.SourceGen+      GHC.SourceGen.Binds+      GHC.SourceGen.Decl+      GHC.SourceGen.Expr+      GHC.SourceGen.Lit+      GHC.SourceGen.Module+      GHC.SourceGen.Name+      GHC.SourceGen.Overloaded+      GHC.SourceGen.Pat+      GHC.SourceGen.Pretty+      GHC.SourceGen.Syntax+      GHC.SourceGen.Type+  other-modules:+      GHC.SourceGen.Binds.Internal+      GHC.SourceGen.Expr.Internal+      GHC.SourceGen.Lit.Internal+      GHC.SourceGen.Name.Internal+      GHC.SourceGen.Syntax.Internal+      GHC.SourceGen.Type.Internal+  hs-source-dirs:+      src+  default-extensions: DataKinds FlexibleInstances TypeSynonymInstances+  build-depends:+      base >=4.7 && <5+    , ghc >=8.2 && <8.9+  default-language: Haskell2010++test-suite pprint_examples+  type: exitcode-stdio-1.0+  main-is: pprint_examples.hs+  other-modules:+      Paths_ghc_source_gen+  hs-source-dirs:+      tests+  default-extensions: DataKinds FlexibleInstances TypeSynonymInstances+  build-depends:+      base >=4.7 && <5+    , ghc >=8.2 && <8.9+    , ghc-paths ==0.1.*+    , ghc-source-gen+  default-language: Haskell2010++test-suite pprint_test+  type: exitcode-stdio-1.0+  main-is: pprint_test.hs+  other-modules:+      Paths_ghc_source_gen+  hs-source-dirs:+      tests+  default-extensions: DataKinds FlexibleInstances TypeSynonymInstances+  build-depends:+      base >=4.7 && <5+    , ghc >=8.2 && <8.9+    , ghc-paths ==0.1.*+    , ghc-source-gen+    , tasty+    , tasty-hunit+  default-language: Haskell2010

@@ -0,0 +1,45 @@+-- 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++-- | This module exports all of the definitions in this package in one+-- convenient location.+--+-- For more details and examples of usage, see+-- <https://github.com/google/ghc-source-gen>.+module GHC.SourceGen+    ( -- * 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,+      module GHC.SourceGen.Module,+      module GHC.SourceGen.Pat,+      module GHC.SourceGen.Type,+      -- * 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.+      module GHC.SourceGen.Binds,+      module GHC.SourceGen.Lit,+      module GHC.SourceGen.Overloaded,+      -- * Renders Haskell syntax into text+      module GHC.SourceGen.Pretty,+    ) where++import GHC.SourceGen.Binds+import GHC.SourceGen.Decl+import GHC.SourceGen.Expr+import GHC.SourceGen.Lit+import GHC.SourceGen.Module+import GHC.SourceGen.Name+import GHC.SourceGen.Overloaded+import GHC.SourceGen.Pat+import GHC.SourceGen.Pretty+import GHC.SourceGen.Syntax+import GHC.SourceGen.Type+

@@ -0,0 +1,223 @@+-- 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++-- | This module provides combinators for constructing Haskell declarations.+module GHC.SourceGen.Binds+    ( -- * Overloaded constructors+      HasValBind(..)+    , typeSig+    , typeSigs+    , funBind+    , funBinds+    -- * Matches+    -- $rawMatch+    , RawMatch+    , match+    , matchRhs+    -- * Right-hand sides+    , RawGRHSs+    , rhs+    -- ** Guards+    , guardedRhs+    , GuardedExpr+    , guards+    , guard+    -- ** Where clauses+    , where'+    , RawValBind+    -- * Statements+    , stmt+    , (<--)+    ) where++import BasicTypes (LexicalFixity(..))+import HsBinds+import HsExpr+import HsDecls+import HsTypes+import TcEvidence (HsWrapper(WpHole))++import GHC.SourceGen.Binds.Internal+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:+--+-- > f, g :: A+-- > =====+-- > typeSigs ["f", "g"] (var "A")+typeSigs :: HasValBind t => [RdrNameStr] -> HsType' -> t+typeSigs names t =+    sigB $ noExt TypeSig (map typeRdrName names)+        $ sigWcType t++-- | Declare that a function or value has a type:+--+-- > f :: A+-- > =====+-- > typeSig "f" (var "A")+typeSig :: HasValBind t => RdrNameStr -> HsType' -> t+typeSig n = typeSigs [n]++-- | Define a function or value.+--+-- > f = x+-- > =====+-- > funBinds "f" [matchRhs [] "x"]+--+-- > id x = x+-- > =====+-- > funBinds "id" [matchRhs [var "x"] (var "x")]+--+-- > not True = False+-- > not False = True+-- > =====+-- > funBinds "not"+-- >   [ matchRhs [conP "True" []] (var "False")+-- >   , matchRhs [conP "False" []] (var "True")+-- >   ]+funBinds :: HasValBind t => RdrNameStr -> [RawMatch] -> t+funBinds name matches = bindB $ withPlaceHolder+        (noExt FunBind name'+            (matchGroup context matches) WpHole)+        []+  where+    name' = valueRdrName name+    context = FunRhs name' Prefix NoSrcStrict++-- | Defines a function that has a single case.+--+-- > f = x+-- > =====+-- > funBind "f" (matchRhs [] "x")+--+-- > id x = x+-- > =====+-- > funBind "id" $ matchRhs [var "x"] (var "x")+--+funBind :: HasValBind t => RdrNameStr -> RawMatch -> t+funBind name m = funBinds name [m]++{- $rawMatch++A function definition is made up of one or more 'RawMatch' terms.  Each+'RawMatch' corresponds to a single pattern match.  For example, to define the+"not" function:++> not True = False+> not False = True++We could using a list of two 'RawMatch'es:++> funBinds "not"+>   [ matchRhs [conP "True" []] (var "False")+>   , matchRhs [conP "False" [] (var "True")+>   ]++A match may consist of one or more guarded expressions.  For example, to+define the function as:++> not x+>   | x = False+>   | otherwise = True++We would say:++> funBind "not"+>      $ match [var "x"] $ guardedRhs+>          [ guard (var "x") (var "False")+>          , guard (var "otherwise") (var "True")+>          ]+-}++-- | A function match consisting of multiple guards.+match :: [Pat'] -> RawGRHSs -> RawMatch+match = RawMatch++-- | A function match with a single case.+matchRhs :: [Pat'] -> HsExpr' -> RawMatch+matchRhs ps = match ps . rhs++-- | Adds a "where" clause to an existing 'RawGRHSs'.+--+-- > f x = y+-- >   where y = x+-- > =====+-- > funBind "x"+-- >   $ match [var "x"]+-- >   $ rhs (var "y")+-- >      `where` [patBind (var "y") $ rhs $ var "x']+where' :: RawGRHSs -> [RawValBind] -> RawGRHSs+where' r vbs = r { rawGRHSWhere = rawGRHSWhere r ++ vbs }++-- | A right-hand side of a match, with no guards.+rhs :: HsExpr' -> RawGRHSs+rhs e = guardedRhs [guards [] e]++-- | A guarded right-hand side of a match.+--+-- >   | x = False+-- >   | otherwise = True+-- > =====+-- > guardedRhs+-- >   [ guard (var "x") (var "False")+-- >   , guard (var "otherwise") (var "True")+-- >   ]+guardedRhs :: [GuardedExpr] -> RawGRHSs+guardedRhs ss = RawGRHSs ss []++-- | An expression guarded by a single boolean statement.+--+-- >   | otherwise = ()+-- > =====+-- > guard (var "otherwise") unit+guard :: HsExpr' -> HsExpr' -> GuardedExpr+guard s = guards [stmt s]++-- | An expression guarded by multiple statements, using the @PatternGuards@ extension.+--+-- >   | Just y <- x, y = ()+-- > =====+-- > guards [conP "Just" (var "x") <-- var "y", var "x"] unit+guards :: [Stmt'] -> HsExpr' -> GuardedExpr+guards stmts e = noExt GRHS (map builtLoc stmts) (builtLoc e)++-- | An expression statement.  May be used in a do expression (with 'do'') or in a+-- match (with 'guard').+--+-- TODO: also allow using statements in list comprehensions.+stmt :: HsExpr' -> Stmt'+-- For now, don't worry about rebindable syntax.+stmt e =+    withPlaceHolder $ noExt BodyStmt (builtLoc e) noSyntaxExpr noSyntaxExpr++-- | A statement that binds a pattern.+--+-- > x <- act+-- > =====+-- > var "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.+--+-- 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++instance HasValBind HsDecl' where+    sigB = noExt SigD+    bindB = noExt ValD

@@ -0,0 +1,103 @@+-- 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 #-}+module GHC.SourceGen.Binds.Internal where++import BasicTypes (Origin(Generated))+import Bag (listToBag)+import HsBinds+import HsExpr (MatchGroup(..), Match(..), GRHSs(..))+import SrcLoc (Located)++#if !MIN_VERSION_ghc(8,6,0)+import PlaceHolder (PlaceHolder(..))+#endif+++import GHC.SourceGen.Syntax+import GHC.SourceGen.Syntax.Internal++data RawValBind+    = SigV Sig'+    | BindV HsBind'++valBinds :: [RawValBind] -> HsLocalBinds'+-- This case prevents GHC from printing an empty "where" clause:+valBinds [] = noExt EmptyLocalBinds+valBinds vbs =+    noExt HsValBinds+#if MIN_VERSION_ghc(8,6,0)+        $ noExt ValBinds+#else+        $ noExt ValBindsIn+#endif+            (listToBag $ map builtLoc binds)+            (map builtLoc sigs)+  where+    sigs = [s | SigV s <- vbs]+    binds = [b | BindV b <- vbs]++-- | A single function pattern match, including an optional "where" clause.+--+-- For example:+--+-- > f x+-- >    | cond = y+-- >    | otherwise = z+-- >  where+-- >    y = ...+-- >    z = ...+data RawMatch = RawMatch+    { rawMatchPats :: [Pat']+    , rawMatchGRHSs :: RawGRHSs+    }++-- | A set of match guards plus an optional "where" clause.+--+-- This type is used in matches and in multi-way if expressions.+--+-- For example:+--+-- >    | cond = y+-- >    | otherwise = z+-- >  where+-- >    y = ...+-- >    z = ...+data RawGRHSs = RawGRHSs+    { rawGRHSs :: [GuardedExpr]+    , rawGRHSWhere :: [RawValBind]+    }++matchGroup :: HsMatchContext' -> [RawMatch] -> MatchGroup' (Located HsExpr')+matchGroup context matches =+    noExt MG (builtLoc $ map (builtLoc . mkMatch) matches)+#if !MIN_VERSION_ghc(8,6,0)+                            [] PlaceHolder+#endif+                            Generated+  where+    mkMatch :: RawMatch -> Match' (Located HsExpr')+    mkMatch r = noExt Match context (map builtPat $ 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.+                    Nothing+#endif+                    (mkGRHSs $ rawMatchGRHSs r)++mkGRHSs :: RawGRHSs -> GRHSs' (Located HsExpr')+mkGRHSs g = noExt GRHSs+                (map builtLoc $ rawGRHSs g)+                (builtLoc $ valBinds $ rawGRHSWhere g)++-- | An expression with a single guard.+--+-- For example:+--+-- > | otherwise = ()+type GuardedExpr = GRHS' (Located HsExpr')+

@@ -0,0 +1,338 @@+-- 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 #-}+-- | This module provides combinators for constructing Haskell declarations.+module GHC.SourceGen.Decl+    ( -- * Type declarations+      type'+    , newtype'+    , data'+      -- * Pattern bindings+    , patBind+      -- * Data constructors+    , prefixCon+    , infixCon+    , recordCon+    , Field+    , field+    , strict+    , lazy+      -- * Class declarations+    , class'+    , ClassDecl+    , funDep+      -- * Instance declarations+    , instance'+    , RawInstDecl+    ) where++import BasicTypes (LexicalFixity(Prefix))+import Bag (listToBag)+import HsBinds (HsBindLR(..))+import HsDecls+import HsTypes+    ( ConDeclField(..)+    , FieldOcc(..)+    , HsConDetails(..)+    , HsSrcBang(..)+    , HsType(..)+    , SrcStrictness(..)+    , SrcUnpackedness(..)+    )+import SrcLoc (Located)++#if MIN_VERSION_ghc(8,6,0)+import HsExtension (NoExt(NoExt))+#else+import PlaceHolder (PlaceHolder(..))+#endif++import GHC.SourceGen.Binds+import GHC.SourceGen.Binds.Internal (mkGRHSs)+import GHC.SourceGen.Lit.Internal (noSourceText)+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.+data ClassDecl+    = ClassSig Sig'+    | ClassDefaultMethod HsBind'+    | ClassFunDep [RdrNameStr] [RdrNameStr]+    -- TODO: type families++instance HasValBind ClassDecl where+    sigB = ClassSig+    bindB = ClassDefaultMethod++-- | A functional dependency for a class.+--+-- > | a, b -> c+-- > =====+-- > funDep ["a", "b"] ["c"]+--+-- > class Ident a b | a -> b, b -> a where+-- >   ident :: a -> b+-- > =====+-- > class' [] "Ident" ["a", "b"]+-- >    [ funDep ["a"] ["b"]+-- >    , funDep ["b"] ["a"]+-- >    , typeSig "ident" $ var "a" --> var "b"+-- >    ]+funDep :: [RdrNameStr] -> [RdrNameStr] -> ClassDecl+funDep = ClassFunDep++-- TODO:+-- - kinded variables+-- - fixity of declaration+-- - functional dependencies+-- - associated types++-- | A class declaration.+--+-- > class (Real a, Enum a) => Integral a where+-- >   divMod :: a -> a -> (a, a)+-- >   div :: a -> a -> a+-- >   div x y = fst (divMod x y)+-- > =====+-- > let a = var "a"+-- > in class'+-- >      [var "Real" @@ a, var "Enum" @@ a]+-- >      "Integral"+-- >      ["a"]+-- >      [ typeSig "divMod" $ a --> a --> tuple [a, a]+-- >      , typeSig "div" $ a --> a --> a+-- >      , funBind "div"+-- >          $ matchRhs [var "x", var "y"]+-- >             $ var "fst" @@ (var "divMod" @@ var "x" @@ var "y")+-- >      ]+class'+    :: [HsType'] -- ^ Context+    -> RdrNameStr -- ^ Class name+    -> [RdrNameStr] -- ^ Type parameters+    -> [ClassDecl] -- ^ Class declarations+    -> HsDecl'+class' context name vars decls+    = noExt TyClD $ ClassDecl+            { tcdCtxt = builtLoc $ map builtLoc context+#if MIN_VERSION_ghc(8,6,0)+            , tcdCExt = NoExt+#else+            , tcdFVs = PlaceHolder+#endif+            , tcdLName = typeRdrName name+            , tcdTyVars = mkQTyVars vars+            , tcdFixity = Prefix+            , tcdFDs = [ builtLoc (map typeRdrName xs, map typeRdrName ys)+                       | ClassFunDep xs ys <- decls+                       ]+            , tcdSigs = [builtLoc sig | ClassSig sig <- decls]+            , tcdMeths =+                listToBag [builtLoc bind | ClassDefaultMethod bind <- decls]+            , tcdATs = []  -- Associated types+            , tcdATDefs = []  -- Associated type defaults+            , tcdDocs = []  -- Haddocks+            }++-- | A definition that can appear in the body of an @instance@ declaration.+data RawInstDecl+    = InstSig Sig'+    | InstBind HsBind'++instance HasValBind RawInstDecl where+    sigB = InstSig+    bindB = InstBind++-- | An instance declaration.+--+-- > instance Show Bool where+-- >   show :: Bool -> String -- Requires the InstanceSigs extension+-- >   show True = "True"+-- >   show False = "False"+-- > =====+-- > instance' (var "Show" @@ var "Bool")+-- >   [ typeSig "show" $ var "Bool" --> var "String"+-- >   , funBinds "show"+-- >       [ matchRhs [var "True"] $ string "True"+-- >       , matchRhs [var "False"] $ string "False"+-- >       ]+-- >   ]+instance' :: HsType' -> [RawInstDecl] -> HsDecl'+instance' ty decls = noExt InstD  $ noExt ClsInstD $ ClsInstDecl+    { cid_poly_ty = sigType ty+#if MIN_VERSION_ghc(8,6,0)+    , cid_ext = NoExt+#endif+    , cid_binds = listToBag [builtLoc b | InstBind b <- decls]+    , cid_sigs = [builtLoc sig | InstSig sig <- decls]+    , cid_tyfam_insts = []+    , cid_datafam_insts = []+    , cid_overlap_mode = Nothing+    }++-- | 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' name vars t =+    noExt TyClD $ withPlaceHolder $ noExt SynDecl (typeRdrName name)+        (mkQTyVars vars)+        Prefix+        (builtLoc t)++newOrDataType ::+    NewOrData -> RdrNameStr -> [RdrNameStr] -> [ConDecl'] -> HsDecl'+newOrDataType newOrData name vars conDecls+    = noExt TyClD $ withPlaceHolder $ withPlaceHolder $+        noExt DataDecl (typeRdrName name)+            (mkQTyVars vars)+            Prefix+            $ noExt HsDataDefn newOrData+                (builtLoc []) Nothing+                Nothing+                (map builtLoc conDecls)+                (builtLoc [])++-- | A newtype declaration.+--+-- > newtype Const a b = Const a+-- > =====+-- > newtype' "Const" ["a", "b"] $ conDecl "Const" [var "a"]+newtype' :: RdrNameStr -> [RdrNameStr] -> ConDecl' -> HsDecl'+newtype' name vars conD = newOrDataType NewType name vars [conD]++-- | A data declaration.+--+-- > data Either a b = Left a | Right b+-- > =====+-- > data' "Either" ["a", "b"]+-- >   [ conDecl "Left" [var "a"]+-- >   , conDecl "Right" [var "b"]+-- >   ]+data' :: RdrNameStr -> [RdrNameStr] -> [ConDecl'] -> HsDecl'+data' = newOrDataType DataType++-- | Declares a Haskell-98-style prefix constructor for a data or type+-- declaration.+--+-- > Foo a Int+-- > =====+-- > conDecl "Foo" [field (var "a"), field (var "Int")]+prefixCon :: RdrNameStr -> [Field] -> ConDecl'+prefixCon name fields = renderCon98Decl name+    $ PrefixCon $ map renderField fields++-- | Declares a Haskell-98-style infix constructor for a data or type+-- declaration.+--+-- > A b :+: C d+-- > =====+-- > infixCon (field (var "A" @@ var "b")) ":+:" (field (Var "C" @@ var "d"))+infixCon :: Field -> RdrNameStr -> Field -> ConDecl'+infixCon f name f' = renderCon98Decl name+    $ InfixCon (renderField f) (renderField f')++-- | Declares Haskell-98-style record constructor for a data or type+-- declaration.+--+-- > A { x :: B, y :: C }+-- > =====+-- > recordCon "A" [("x", var "B"), ("y", var "C")]+recordCon :: RdrNameStr -> [(RdrNameStr, 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]+                        (renderField f)+                        Nothing++-- | An individual argument of a data constructor.  Contains a type for the field,+-- and whether the field is strict or lazy.+data Field = Field+    { fieldType :: HsType'+    , strictness :: SrcStrictness+    }++-- | A field with no explicit strictness annotations.+--+-- > A b+-- > =====+-- > field $ var "A" @@ var "b"+field :: HsType' -> Field+field t = Field t NoSrcStrict++-- | Give a field an explicit strictness annotation.  Overrides any such previous+-- annotations (for example, from 'lazy').+--+-- > !(A b)+-- > =====+-- > strict $ field $ var "A" @@ var "b"+strict :: Field -> Field+strict f = f { strictness = SrcStrict }++-- | Give a field an explicit laziness annotation.  This feature is useful in combination+-- with the @StrictData@ extension.  Overrides any such previous+-- annotations (for example, from 'strict').+--+-- > !(A b)+-- > =====+-- > strict $ field $ var "A" @@ var "b"+lazy :: Field -> Field+lazy f = f { strictness = SrcLazy }++renderField :: Field -> Located HsType'+-- TODO: parenthesizeTypeForApp is an overestimate in the case of+-- rendering an infix or record type.+renderField f = wrap $ parenthesizeTypeForApp $ builtLoc $ fieldType f+  where+    wrap = case strictness f of+        NoSrcStrict -> id+        s -> builtLoc . (noExt HsBangTy $ noSourceText HsSrcBang NoSrcUnpack s)++renderCon98Decl :: RdrNameStr -> HsConDeclDetails' -> ConDecl'+renderCon98Decl name details = noExt ConDeclH98 (typeRdrName name)+#if MIN_VERSION_ghc(8,6,0)+    (builtLoc False)+    []+#else+    Nothing+#endif+    Nothing+    details+    Nothing++-- | A pattern binding.+--+-- > x = y+-- > =====+-- > patBind (var "x") $ rhs $ var "y"+--+-- > (x, y) = e+-- > =====+-- > patBind (tuple [var "x", var "y"]) $ rhs e+--+-- > (x, y)+-- >   | test = (1, 2)+-- >   | otherwise = (2, 3)+-- > =====+-- > patBind (tuple [var "x", var "y"])+-- >   $ 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)))+        $ ([],[])

@@ -0,0 +1,104 @@+-- 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 #-}+-- | This module provides combinators for constructing Haskell expressions.+module GHC.SourceGen.Expr where++import HsExpr+import Data.String (fromString)+import SrcLoc (unLoc)++import GHC.SourceGen.Binds.Internal+import GHC.SourceGen.Binds+import GHC.SourceGen.Syntax+import GHC.SourceGen.Syntax.Internal+import GHC.SourceGen.Type.Internal+    ( parenthesizeTypeForApp+    , sigWcType+    , wcType+    )++-- | An overloaded label, as used with the @OverloadedLabels@ extension.+--+-- > #foo+-- > =====+-- > overLabel "foo"+overLabel :: String -> HsExpr'+overLabel = noExt HsOverLabel Nothing . fromString++let' :: [RawValBind] -> HsExpr' -> HsExpr'+let' binds e = noExt HsLet (builtLoc $ valBinds binds) $ builtLoc e++case' :: HsExpr' -> [RawMatch] -> HsExpr'+case' e matches = noExt HsCase (builtLoc e)+                    $ matchGroup CaseAlt matches++lambda :: [Pat'] -> HsExpr' -> HsExpr'+lambda ps e = noExt HsLam $ matchGroup LambdaExpr [matchRhs ps e]++lambdaCase :: [RawMatch] -> HsExpr'+lambdaCase = noExt HsLamCase . matchGroup CaseAlt++if' :: HsExpr' -> HsExpr' -> HsExpr' -> HsExpr'+if' x y z = noExt HsIf Nothing (builtLoc x) (builtLoc y) (builtLoc z)++-- | A MultiWayIf expression.+--+-- > if | f x = "f"+-- >    | g x = "g"+-- >    | otherwise = "h"+-- > =====+-- > multiIf+-- >     [ guardedStmt (var "f" @@ var "x") $ rhs (string "f")+-- >     , guardedStmt (var "g" @@ var "x") $ rhs (string "g")+-- >     , guardedStmt (var "otherwise") $ rhs (string "h")+-- >     ]+multiIf :: [GuardedExpr] -> HsExpr'+multiIf = noExtOrPlaceHolder HsMultiIf . map builtLoc++-- | A do-expression.+--+-- Individual statements may be constructed with '<--' and/or 'stmt'.+--+-- > do+-- >   x <- act+-- >   return x+-- > =====+-- > do' [var "x" <-- var "act", stmt $ var "return" @@ var "x"]+do' :: [Stmt'] -> HsExpr'+do' = withPlaceHolder . noExt HsDo DoExpr . builtLoc . map builtLoc++-- | A type constraint on an expression.+--+-- > e :: t+-- > =====+-- > var "e" @::@ var "t"+(@::@) :: HsExpr' -> HsType' -> HsExpr'+#if MIN_VERSION_ghc(8,8,0)+e @::@ t = noExt ExprWithTySig (builtLoc e) (sigWcType t)+#elif MIN_VERSION_ghc(8,6,0)+e @::@ t = ExprWithTySig (sigWcType t) (builtLoc e)+#else+e @::@ t = ExprWithTySig (builtLoc e) (sigWcType t)+#endif+-- TODO: The Outputable instance prepends extra spaces; I'm not sure why.++-- | Explicit type application.+--+-- > f @ Int+-- > =====+-- > var "f" @@ var "Int"+tyApp :: HsExpr' -> HsType' -> HsExpr'+#if MIN_VERSION_ghc(8,8,0)+tyApp e t = noExt HsAppType (builtLoc e) t'+#elif MIN_VERSION_ghc(8,6,0)+tyApp e t = HsAppType t' (builtLoc e)+#else+tyApp e t = HsAppType (builtLoc e) t'+#endif+  where+    t' = wcType $ unLoc $ parenthesizeTypeForApp $ builtLoc t

@@ -0,0 +1,75 @@+-- 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 #-}+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.Syntax.Internal++parenthesizeExprForApp, parenthesizeExprForOp+    :: Located HsExpr' -> Located HsExpr'+parenthesizeExprForApp e +    | needsExprForApp (unLoc e) = parExpr e+    | otherwise = e+parenthesizeExprForOp e+    | needsExprForOp (unLoc e) = parExpr e+    | otherwise = e++parExpr :: Located HsExpr' -> Located HsExpr'+parExpr = builtLoc . noExt HsPar++#if MIN_VERSION_ghc(8,6,0)+#define WILD_EXT _+#else+#define WILD_EXT+#endif++needsExprForApp, needsExprForOp :: HsExpr' -> Bool+needsExprForOp e = case e of+    -- TODO: more care for literals; only needed for negative numbers?+    HsLit WILD_EXT l -> litNeedsParen l+    HsOverLit WILD_EXT l -> overLitNeedsParen l+    HsLam{} -> True+    HsLamCase{} -> True+    OpApp{} -> True+    NegApp{} -> True+    HsCase{} -> True+    HsIf{} -> True+    HsMultiIf{} -> True+    HsLet{} -> True+    HsDo{} -> True+    ExprWithTySig{} -> True+    _ -> False+needsExprForApp e = case e of+    HsApp{} -> 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

@@ -0,0 +1,62 @@+-- 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 #-}+-- | This module provides combinators for constructing Haskell literals,+-- which may be used in either patterns or expressions.+module GHC.SourceGen.Lit where++import BasicTypes (FractionalLit(..))+#if MIN_VERSION_ghc(8,4,0)+import BasicTypes(IntegralLit(..))+#endif+import HsLit+import HsExpr (noExpr, noSyntaxExpr, HsExpr(..))+import HsPat (Pat(..))+import FastString (fsLit)++import GHC.SourceGen.Lit.Internal+import GHC.SourceGen.Syntax+import GHC.SourceGen.Syntax.Internal++class HasLit e where+    lit :: HsLit' -> e+    overLit :: HsOverLit' -> e++instance HasLit HsExpr' where+    lit = noExt HsLit+    overLit = noExt HsOverLit++instance HasLit Pat' where+    lit = noExt LitPat+    overLit l = withPlaceHolder+                    $ noExt NPat (builtLoc l) Nothing noSyntaxExpr++char :: HasLit e => Char -> e+char = lit . noSourceText HsChar++string :: HasLit e => String -> e+string = lit . noSourceText HsString . fsLit++-- | Note: this is an *overloaded* integer.+int :: HasLit e => Integer -> e+int n = overLit $ withPlaceHolder $ withPlaceHolder (noExt OverLit il) noExpr+  where+#if MIN_VERSION_ghc(8,4,0)+    il = HsIntegral $ noSourceText IL (n < 0) n+#else+    il = noSourceText HsIntegral n+#endif++-- | Note: this is an *overloaded* rational, e.g., a decimal number.+frac :: HasLit e => Rational -> e+frac x = overLit $ withPlaceHolder $ withPlaceHolder (noExt OverLit $ HsFractional il) noExpr+  where+#if MIN_VERSION_ghc(8,4,0)+    il = noSourceText FL (x < 0) x+#else+    il = FL (show x) x+#endif

@@ -0,0 +1,12 @@+-- 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++module GHC.SourceGen.Lit.Internal where++import BasicTypes (SourceText(NoSourceText))++noSourceText :: (SourceText -> a) -> a+noSourceText = ($ NoSourceText)

@@ -0,0 +1,53 @@+-- 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++-- | This module provides combinators for constructing Haskell modules,+-- including import and export statements.+module GHC.SourceGen.Module where++import HsSyn+    ( HsModule(..)+    , ImportDecl(..)+    )++import GHC.SourceGen.Syntax+import GHC.SourceGen.Syntax.Internal+import GHC.SourceGen.Name.Internal+import GHC.SourceGen.Lit.Internal (noSourceText)++module'+    :: Maybe ModuleNameStr+    -> Maybe [IE'] -- ^ Exports+    -> [ImportDecl']+    -> [HsDecl']+    -> HsModule'+module' name exports imports decls = HsModule+    { hsmodName = fmap (builtLoc . unModuleNameStr) name+    , hsmodExports = fmap (builtLoc . map builtLoc) exports+    , hsmodImports = map builtLoc imports+    , hsmodDecls = fmap builtLoc decls+    , hsmodDeprecMessage = Nothing+    , hsmodHaddockModHeader = Nothing+    }++qualified' :: ImportDecl' -> ImportDecl'+qualified' d = d { ideclQualified = True }++as' :: ImportDecl' -> ModuleNameStr -> ImportDecl'+as' d m = d { ideclAs = Just (builtLoc $ unModuleNameStr m) }++import' :: ModuleNameStr -> ImportDecl'+import' m = noSourceText (noExt ImportDecl)+            (builtLoc $ unModuleNameStr m)+            Nothing False False False False Nothing Nothing++exposing :: ImportDecl' -> [IE'] -> ImportDecl'+exposing d ies = d+    { ideclHiding = Just (False, builtLoc $ map builtLoc ies) }++hiding :: ImportDecl' -> [IE'] -> ImportDecl'+hiding d ies = d+    { ideclHiding = Just (True, builtLoc $ map builtLoc ies) }

@@ -0,0 +1,26 @@+-- 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++-- | This module defines custom types for defining names of various+-- syntax terms.+--+-- These types are all instances of 'Data.String.IsString'.  For easier use,+-- we recommend enabling the @OverloadedStrings@ extension.+module GHC.SourceGen.Name+    ( RdrNameStr(..)+    , OccNameStr+    , ModuleNameStr(..)+    , qual+    , unqual+    ) where++import GHC.SourceGen.Name.Internal++unqual :: OccNameStr -> RdrNameStr+unqual = RawUnqual++qual :: ModuleNameStr -> OccNameStr -> RdrNameStr+qual = RawQual

@@ -0,0 +1,72 @@+-- 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++module GHC.SourceGen.Name.Internal where++import Data.Char (isUpper)+import Data.String (IsString(..))+import FastString (FastString, fsLit)+import Module (mkModuleNameFS, ModuleName)+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.+data OccNameStr = OccNameStr !RawNameSpace !FastString++data RawNameSpace = Constructor | Value+-- TODO: symbols++rawNameSpace :: String -> RawNameSpace+rawNameSpace (c:_)+    | isUpper c = Constructor+rawNameSpace _ = Value++instance IsString OccNameStr where+    fromString s = OccNameStr (rawNameSpace s) (fsLit s)++valueOccName, typeOccName :: OccNameStr -> OccName+valueOccName (OccNameStr Constructor s) = mkDataOccFS s+valueOccName (OccNameStr Value s) = mkVarOccFS s+typeOccName (OccNameStr Constructor s) = mkTcOccFS s+typeOccName (OccNameStr Value s) = mkTyVarOccFS s++-- | A newtype wrapper around 'ModuleName' which is an instance of 'IsString'.+newtype ModuleNameStr = ModuleNameStr { unModuleNameStr :: ModuleName }++instance IsString ModuleNameStr where+    fromString = ModuleNameStr . mkModuleNameFS . fsLit++-- | A string identifier which may be qualified to a particular module.+--+-- For example:+--+-- > fromString "A.b.c" == RawQual (fromString "A.b") (fromString "c")+-- > fromString "c" == RawUnqual (fromString "c")+--+-- 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++-- 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++-- 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)

@@ -0,0 +1,235 @@+-- 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 #-}+-- | This module overloads some combinators so they can be used in+-- different contexts: for expressions, types and/or patterns.+module GHC.SourceGen.Overloaded+    ( Par(..)+    , App(..)+    , HasTuple(..)+    , tuple+    , unboxedTuple+    , HasList(..)+    , Var(..)+    ) where++import BasicTypes (Boxity(..))+import HsTypes+    ( HsType(..)+    , HsTyVarBndr(..)+    )+import HsSyn (IE(..), IEWrappedName(..))+#if !MIN_VERSION_ghc(8,6,0)+import PlaceHolder(PlaceHolder(..))+#endif++import HsSyn+    ( HsExpr(..)+    , Pat(..)+    , HsTupArg(..)+    , HsTupleSort(..)+    )+import DataCon (dataConName)+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++-- | A class for wrapping terms in parentheses.+class Par e where+    par :: e -> e++instance Par HsExpr' where+    par = noExt HsPar . builtLoc++instance Par Pat' where+    par = noExt ParPat . builtPat++instance Par HsType' where+    par = noExt HsParTy . builtLoc++-- | A class for term application.+--+-- These functions may add additional parentheses to the AST.+-- GHC's pretty-printing functions expect those parentheses+-- to already be present, because GHC preserves parentheses when it+-- parses the AST from a source file.+class App e where+    -- | Prefix-apply a term:+    --+    -- > f x+    -- > =====+    -- > var "f" @@ var "x"+    --+    -- > (+) x+    -- > =====+    -- > var "+" @@ var "x"+    --+    -- Also parenthesizes the right-hand side in order to preserve its+    -- semantics when pretty-printed, but tries to do so only when+    -- necessary:+    --+    -- > f x y+    -- > =====+    -- > var "f" @@ var "x" @@ var "y"+    -- > -- equivalently:+    -- > (var "f" @@ var "x") @@ var "y"+    --+    -- > f (g x)+    -- > =====+    -- > var "f" @@ (var "g" @@ var "x")+    --+    -- > f (g x)+    -- > =====+    -- > var "f" @@ par (var "g" @@ par (var "x"))+    (@@) :: e -> e -> e++    -- | Infix-apply an operator or function.+    --+    -- For example:+    --+    -- > x + y+    -- > =====+    -- > op (var "x") "+" (var "y")+    --+    -- Also parenthesizes the right-hand side in order to preserve its+    -- semantics when pretty-printed, but tries to do so only when necessary:+    --+    -- > f x + g y+    -- > =====+    -- > op (var "f" @@ var "x") "+" (var "g" @@ var "y")+    --+    -- > x + (y + z)+    -- > =====+    -- > op (var "x") "+" (op (var "y") "+" (var "z"))+    --+    -- > f x `plus` g y+    -- > =====+    -- > op (var "f" @@ var "x") "plus" (var "g" @@ var "y")+    op :: e -> RdrNameStr -> e -> e+infixl 2 @@++instance App HsExpr' where+    op x o y+        = noExt OpApp+            (parenthesizeExprForOp $ builtLoc x)+            (builtLoc $ var o)+#if !MIN_VERSION_ghc(8,6,0)+            PlaceHolder+#endif+            (parenthesizeExprForOp $ builtLoc y)+    x @@ y = noExt HsApp (builtLoc x)+                (parenthesizeExprForApp $ builtLoc y)++instance App HsType' where+    op x o y+        = noExt HsOpTy (parenthesizeTypeForOp $ builtLoc x)+                (typeRdrName o)+                (parenthesizeTypeForOp $ builtLoc y)+    x @@ y = noExt HsAppTy+                (builtLoc x)+                (parenthesizeTypeForApp $ builtLoc y)++class HasTuple e where+    unit :: e+    tupleOf :: Boxity -> [e] -> e++tuple, unboxedTuple :: HasTuple e => [e] -> e+tuple = tupleOf Boxed+unboxedTuple = tupleOf Unboxed++instance HasTuple HsExpr' where+    tupleOf b ts =+        noExt ExplicitTuple+            (map (builtLoc . noExt Present . builtLoc) ts)+            b+    unit = noExt HsVar unitDataConName++unitDataConName :: Located RdrName+unitDataConName = builtLoc $ nameRdrName $ dataConName $ unitDataCon++instance HasTuple HsType' where+    tupleOf b = noExt HsTupleTy b' . map builtLoc+        where+            b' = case b of+                    Unboxed -> HsUnboxedTuple+                    -- See the note [Unit tuples] in HsType.hs for why+                    -- this isn't just HsBoxed.+                    Boxed -> HsBoxedOrConstraintTuple+    unit = tupleOf Boxed []++instance HasTuple Pat' where+    tupleOf b ps =+        noExt TuplePat (map builtPat ps) b+#if !MIN_VERSION_ghc(8,6,0)+        []+#endif+    unit = noExt VarPat unitDataConName++-- | An explicit list of terms.+--+-- > [x, y]+-- > =====+-- > list [var "x", var "y"]+--+-- NOTE: for types, use either @listTy@ or @promotedListTy@.+class HasList e where+    list :: [e] -> e+    -- | The empty list @[]@.+    nil :: e++    -- | The list cons constructor @(:)@.+    cons :: e++-- TODO: allow something like "consOp" which applies (:) as an operator, but using+-- the built-in RdrName.++nilDataConName :: Located RdrName+nilDataConName = builtLoc $ nameRdrName $ dataConName $ nilDataCon++instance HasList HsExpr' where+    list = withPlaceHolder (noExt ExplicitList) Nothing . map builtLoc+    nil = noExt HsVar nilDataConName+    cons = noExt HsVar $ builtLoc consDataCon_RDR++instance HasList Pat' where+#if MIN_VERSION_ghc(8,6,0)+    list = noExt ListPat . map builtPat+#else+    list ps = ListPat (map builtPat ps) PlaceHolder Nothing+#endif+    nil = noExt VarPat nilDataConName+    cons = noExt VarPat $ builtLoc $ consDataCon_RDR++-- | 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+    var :: RdrNameStr -> a++instance Var Pat' where+    var = noExt VarPat . valueRdrName++instance Var HsExpr' where+    var = noExt HsVar . valueRdrName++instance Var HsType' where+    var = noExt HsTyVar notPromoted . typeRdrName++instance Var HsTyVarBndr' where+    var = noExt UserTyVar . typeRdrName++instance Var IE' where+    var = noExt IEVar . builtLoc . IEName . valueRdrName

@@ -0,0 +1,51 @@+-- 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++-- | This module provides combinators for constructing Haskell patterns.+module GHC.SourceGen.Pat where++import HsTypes+import HsPat++import GHC.SourceGen.Name.Internal+import GHC.SourceGen.Syntax+import GHC.SourceGen.Syntax.Internal++-- | A wild pattern (@_@).+wildP :: Pat'+wildP = noExtOrPlaceHolder WildPat++-- | An as-pattern.+--+-- > a@B+-- > =====+-- > asP "a" (var "B")+asP :: RdrNameStr -> Pat' -> Pat'+v `asP` p = noExt AsPat (valueRdrName v) $ builtPat p++-- | A pattern constructor.+--+-- > A b c+-- > =====+-- > conP "A" [var "b", var "c"]+conP :: RdrNameStr -> [Pat'] -> Pat'+conP c xs = ConPatIn (valueRdrName c) $ PrefixCon $ map builtPat xs++-- | A bang-pattern.+--+-- > !x+-- > =====+-- > strictP (var x)+strictP :: Pat' -> Pat'+strictP = noExt BangPat . builtPat++-- | A lazy pattern match.+--+-- > ~(A x)+-- > =====+-- > lazyP (conP "A" [var x])+lazyP :: Pat' -> Pat'+lazyP = noExt LazyPat . builtPat

@@ -0,0 +1,25 @@+-- 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++-- | This module provides utilities for rendering GHC syntax as strings.+module GHC.SourceGen.Pretty+    ( showPpr+    , putPpr+    , hPutPpr+    ) where++import DynFlags+import GhcMonad+import Outputable+import System.IO++hPutPpr :: Outputable a => Handle -> a -> Ghc ()+hPutPpr h x = do+    dflags <- getDynFlags+    liftIO $ printForUser dflags h neverQualify $ ppr x++putPpr :: Outputable a => a -> Ghc ()+putPpr = hPutPpr stdout

@@ -0,0 +1,109 @@+-- 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

@@ -0,0 +1,73 @@+-- 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 #-}+module GHC.SourceGen.Syntax.Internal where++import SrcLoc (SrcSpan, Located, GenLocated(..), mkGeneralSrcSpan)++#if MIN_VERSION_ghc(8,8,0)+import BasicTypes (PromotionFlag(..))+#else+import HsTypes (Promoted(..))+#endif++#if MIN_VERSION_ghc(8,6,0)+import HsExtension (NoExt(NoExt))+#else+import PlaceHolder(PlaceHolder(..))+#endif+import GHC.SourceGen.Syntax++#if MIN_VERSION_ghc(8,6,0)+noExt :: (NoExt -> a) -> a+noExt = ($ NoExt)++noExtOrPlaceHolder :: (NoExt -> a) -> a+noExtOrPlaceHolder = noExt++withPlaceHolder :: a -> a+withPlaceHolder = id++#else++noExt :: a -> a+noExt = id++noExtOrPlaceHolder :: (PlaceHolder -> a) -> a+noExtOrPlaceHolder = withPlaceHolder++withPlaceHolder :: (PlaceHolder -> a) -> a+withPlaceHolder = ($ PlaceHolder)++#endif++builtSpan :: SrcSpan+builtSpan = mkGeneralSrcSpan "<ghc-source-gen>"++builtLoc :: e -> Located e+builtLoc = L builtSpan++-- In GHC-8.8, source locations for Pat aren't stored in each node, and+-- LPat is a synonym for Pat.+#if MIN_VERSION_ghc(8,8,0)+builtPat :: Pat' -> Pat'+builtPat = id+#else+builtPat :: Pat' -> Located Pat'+builtPat = builtLoc+#endif++#if MIN_VERSION_ghc(8,8,0)+promoted, notPromoted :: PromotionFlag+promoted = IsPromoted+notPromoted = NotPromoted+#else+promoted, notPromoted :: Promoted+promoted = Promoted+notPromoted = NotPromoted+#endif

@@ -0,0 +1,54 @@+-- 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++-- | This module provides combinators for constructing Haskell types.+module GHC.SourceGen.Type 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+import GHC.SourceGen.Type.Internal++-- | A promoted name, for example from the @DataKinds@ extension.+tyPromotedVar :: RdrNameStr -> HsType'+tyPromotedVar = noExt HsTyVar notPromoted . typeRdrName++stringTy :: String -> HsType'+stringTy = noExt HsTyLit . noSourceText HsStrTy . fromString++numTy :: Integer -> HsType'+numTy = noExt HsTyLit . noSourceText HsNumTy++listTy :: HsType' -> HsType'+listTy = noExt HsListTy . builtLoc++listPromotedTy :: [HsType'] -> HsType'+listPromotedTy = withPlaceHolder (noExt HsExplicitListTy notPromoted) . map builtLoc++-- | A function type.+--+-- > a -> b+-- > =====+-- > var "a" --> var "b"+(-->) :: HsType' -> HsType' -> HsType'+a --> b = noExt HsFunTy (parenthesizeTypeForFun $ builtLoc a) (builtLoc b)++infixr 0 -->++forall' :: [HsTyVarBndr'] -> HsType' -> HsType'+forall' ts = noExt HsForAllTy (map builtLoc ts) . builtLoc++-- | Qualify a type with constraints.+--+-- > (F x, G x) => x+-- > =====+-- > [var "F" @@ var "x", var "G" @@ var "x"] ==> var "x"+(==>) :: [HsType'] -> HsType' -> HsType'+(==>) cs = noExt HsQualTy (builtLoc (map builtLoc cs)) . builtLoc

@@ -0,0 +1,64 @@+-- 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 #-}+module GHC.SourceGen.Type.Internal where++import HsTypes+import SrcLoc (Located, unLoc)++import GHC.SourceGen.Syntax+import GHC.SourceGen.Syntax.Internal+import GHC.SourceGen.Name.Internal++mkQTyVars :: [RdrNameStr] -> LHsQTyVars'+mkQTyVars vars =  withPlaceHolder+                $ noExt (withPlaceHolder HsQTvs)+                $ map (builtLoc . noExt UserTyVar . typeRdrName)+                    vars++sigType :: HsType' -> LHsSigType'+sigType t = withPlaceHolder $ noExt (withPlaceHolder HsTypes.HsIB) $ builtLoc t+++-- TODO: GHC >= 8.6 provides parenthesizeHsType.  For consistency with+-- older versions, we're implementing our own parenthesis-wrapping.+-- Once we stop supporting GHC-8.4, we can switch to that implementation.++parenthesizeTypeForApp, parenthesizeTypeForOp, parenthesizeTypeForFun+    :: Located HsType' -> Located HsType'+parenthesizeTypeForApp t+    | needsParenForApp (unLoc t) = parTy t+    | otherwise = t+parenthesizeTypeForOp t+    | needsParenForOp (unLoc t) = parTy t+    | otherwise = t+parenthesizeTypeForFun t+    | needsParenForFun (unLoc t) = parTy t+    | otherwise = t++needsParenForFun, needsParenForOp, needsParenForApp+    :: HsType' -> Bool+needsParenForFun t = case t of+    HsForAllTy{} -> True+    HsQualTy{} -> True+    HsFunTy{} -> True+    _ -> False+needsParenForOp t = case t of+    HsOpTy{} -> True+    _ -> needsParenForFun t+needsParenForApp t = case t of+    HsAppTy {} -> True+    _ -> needsParenForOp t++parTy :: Located HsType' -> Located HsType'+parTy = builtLoc . noExt HsParTy++sigWcType :: HsType' -> LHsSigWcType'+sigWcType = noExt (withPlaceHolder HsTypes.HsWC) . sigType++wcType :: HsType' -> LHsWcType'+wcType = noExt (withPlaceHolder HsTypes.HsWC) . builtLoc

@@ -0,0 +1,220 @@+-- 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++-- | Simple example using this package+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+module Main (main) where++import GHC.Paths (libdir)+import GHC (runGhc)+import Outputable (Outputable)++import GHC.SourceGen++main :: IO ()+main = mapM_ run [test1, test2, test3, test4, test5]+  where+    run act = putStrLn "========" >> act++pprint :: Outputable a => a -> IO ()+pprint x = runGhc (Just libdir) $ putPpr x++test1 :: IO ()+test1 = pprint $ tuple+    [ var "Foo.abc"+    , overLabel "def"+    , char 'g'+    , let' [ typeSig "result" $ var "A" @@ var "B"+           , funBind "result"+                $ matchRhs [var "x", wildP]+                    $ var "foo" @@ char 'c'+           ]+        (var "result")+    ]++test2 :: IO ()+test2 = pprint $ module' (Just "Foo") (Just [var "efg"]) []+    [ typeSigs ["efg", "h"] $ tuple [var "A", var "B"]+    , funBind "efg"+        $ match []+        $ rhs (char 'a')+            `where'` [ typeSig "q" $ var "Q"+                     , funBind "q" $ match []+                        $ guardedRhs [var "True" `guard` char 'q']+                     ]+    , funBind "f"+        $ match [var "x", var "y"]+        $ rhs+            (case' (var "y")+                        [matchRhs [wildP] $ var "x"])+            `where'` [funBind "q" $ matchRhs [] $ char 't']+    ]++test3 :: IO ()+test3 = pprint $ module' Nothing Nothing []+    [ funBind "lambdas" $ matchRhs [] $ lambda [var "y"]+                    $ lambdaCase [matchRhs [var "z"] (char 'a')]+    , funBinds "ifs"+        [ matchRhs [var "x"] $ if' (var "b") (var "t") (var "f")+        , matchRhs [var "y"] $ multiIf [guard (var "False") $ char 'f'+                                       , guard (var "True") $ char 't'+                                       ]+        , matchRhs [var "z"] $ multiIf+            [ guard (var "f" @@ var "x") $ string "f"+            , guard (var "g" @@ var "x") $ string "g"+            , guard (var "otherwise") $ string "h"+            ]+        ]+    , funBind "do'"+        $ matchRhs [] (do' [ var "x" <-- var "act"+                        , stmt $ var "return" @@ var "x"+                        ])+    , typeSig "types"+        $ forall' [var "x", var "y"]+        $ [var "Show" @@ var "x"] ==> var "y"+    , typeSig "types'"+        $ [var "Show" @@ var "x"] ==>+            (forall' [var "x", var "y"]+                $ var "y")+    , funBind "swap"+        $ matchRhs [tuple [var "x", var "y"]]+            $ tuple [var "y", var "x"]+    , funBind "char" $ matchRhs [char 'a'] (char 'b')+    , funBind "string" $ matchRhs [string "abc"] (string "def")+    , funBind "as"+        $ matchRhs [asP "x" (tuple [var "y", var "z"])]+            (var "x")+    , funBind "con"+        $ matchRhs [conP "A" [var "b", conP "C" [var "d"]]]+            $ tuple [var "b", var "d"]+    , funBind "ops"+        $ matchRhs [var "x", var "y"]+            $ op (var "x") "+" (var "y")+    , funBinds "ops'"+        [ matchRhs [] (op (int 1) "*"+                        (op (int 2) "+" (int 3)))+        , matchRhs [] (op (var "A" @@ var "x") "*"+                        (op (var "B" @@ var "y") "+"+                                 (var "C" @@ var "z")))+        , matchRhs [] (op (var "A" @@ var "x") "mult"+                        (op (var "B" @@ var "y") "+"+                                 (var "C" @@ var "z")))+        ]+    , funBinds "cons'"+        [ matchRhs [] (var "X" @@ int 1 @@+                        (var "Y" @@ int 2 @@ int 3)+                        @@ var "Z")+        , matchRhs [] (var "f" @@ par (var "g" @@ var "x"))+        ]+    , typeSig "f" $ var "X" @@ var "a" @@+                        (var "Y" @@ var "b" @@ var "c")+                        @@ var "Z"+    , typeSig "g" $ op (var "A" @@ var "x") "*"+                        (op (var "B" @@ var "y") "+"+                                 (var "C" @@ var "z"))+    , class' [var "A" @@ var "a"] "B" ["b", "b'"]+        [ typeSig "f" $ var "b" --> var "b'"+        , funBind "f" $ matchRhs [] $ var "id"+        ]+    , class' [] "F" ["a", "b", "c"]+        [ funDep ["a", "b"] ["c"]+        , funDep ["a"] ["b", "c"]+        ]+    , class' [] "Ident" ["a", "b"]+        [ funDep ["a"] ["b"]+        , funDep ["b"] ["a"]+        , typeSig "ident" $ var "a" --> var "b"+        ]+    , type' "A" ["b", "c"] $ var "D"+    , data' "A" ["b", "c"]+        [ prefixCon "A" [field (var "b"), field (var "c")]+        , prefixCon "D" []+        ]+    , newtype' "A" ["b", "c"] (prefixCon "A" [field (var "b")])+    , instance' (var "A" @@ var "b" @@ var "c")+        [ typeSig "f" $ var "b" --> var "c"+        , funBind "f" $ matchRhs [] $ var "undefined"+        ]+    , let a = var "a"+      in class'+           [var "Real" @@ a, var "Enum" @@ a]+           "Integral"+           ["a"]+           [ typeSig "divMod" $ a --> a --> tuple [a, a]+           , typeSig "div" $ a --> a --> a+           , funBind "div"+               $ matchRhs [var "x", var "y"]+                  $ var "fst" @@ (var "divMod" @@ var "x" @@ var "y")+           ]+    , instance' (var "Show" @@ var "Bool")+        [ typeSig "show" $ var "Bool" --> var "String"+        , funBinds "show"+            [ matchRhs [var "True"] $ string "True"+            , matchRhs [var "False"] $ string "False"+            ]+        ]+    , data' "X" ["b"]+        [ prefixCon "X"+            [ field $ var "A" @@ var "b"+            , strict $ field $ var "A" @@ var "b"+            , lazy $ field $ var "A" @@ var "b"+            ]+        , prefixCon ":+"+            [ field $ var "A" @@ var "b"+            , strict $ field $ var "A" @@ var "b"+            , lazy $ field $ var "A" @@ var "b"+            ]+        , infixCon+            (strict $ field $ var "A" @@ var "b")+            "Y"+            (lazy $ field $ var "A" @@ var "b")+        , infixCon+            (strict $ field $ var "A" @@ var "b")+            ":*"+            (lazy $ field $ var "A" @@ var "b")+        , infixCon+            (field $ var "A" @@ var "b")+            ":*"+            (field $ var "A" @@ var "b")+        , recordCon "Z"+            [ ("x", field $ var "Int")+            , ("y", field $ var "A" @@ var "b")+            , ("y", strict $ field $ var "A" @@ var "b")+            , ("y", lazy $ field $ var "A" @@ var "b")+            ]+        ]+    , funBind "strictness"+        $ matchRhs+            [strictP (conP "A" [var "b"]),+             lazyP (conP "A" [var "b"])+            ] (char 'x')+    , typeSig "unit" $ unit --> unit+    , funBind "unit" $ matchRhs [unit] unit+    ]++test4 :: IO ()+test4 = pprint constModule++test5 :: IO ()+test5 = pprint $ module' (Just "M") (Just exports) imports []+  where+    exports = [var "a", var "b"]+    imports = [ qualified' $ import' "A"+              , import' "B" `as'` "C"+              , import' "D" `exposing` [var "d"]+              , import' "E" `hiding` [var "e"]+              ]++constModule :: HsModule'+constModule = module' (Just "Const") (Just [var "const"]) []+    [ typeSig "const" $ a --> b --> a+    , funBind "const" $ matchRhs [wildP, x] x+    ]+  where+    a = var "a"+    b = var "b"+    x = var "x"

@@ -0,0 +1,176 @@+{-# LANGUAGE OverloadedStrings #-}+module Main(main) where++import DynFlags (getDynFlags)+import GhcMonad (liftIO)+import GHC.Paths (libdir)+import GHC (runGhc, DynFlags)+import Outputable (Outputable)++import Test.Tasty+import Test.Tasty.HUnit++import GHC.SourceGen++data TestCase a = String :~ a++infixr 0 :~++testCases :: Outputable a => DynFlags -> String -> [TestCase a] -> TestTree+testCases dflags name cases = testCase name $ mapM_ run cases+  where+    run (expected :~ x) = expected @=? showPpr dflags x++testTypes :: DynFlags ->  String -> [TestCase HsType'] -> TestTree+testTypes = testCases++testExprs :: DynFlags ->  String -> [TestCase HsExpr'] -> TestTree+testExprs = testCases++testDecls :: DynFlags ->  String -> [TestCase HsDecl'] -> TestTree+testDecls = testCases++main :: IO ()+main = runGhc (Just libdir) $ do+    dflags <- getDynFlags+    liftIO $ defaultMain $ testGroup "Tests"+        [typesTest dflags, exprsTest dflags, declsTest dflags]++typesTest, exprsTest, declsTest :: DynFlags -> TestTree+typesTest dflags = testGroup "Type"+    [ test "var"+        [ "A" :~ var "A"+        , "x" :~ var "x"+        , "A.x" :~ var "A.x"+        , "x" :~ var (unqual "x")+        , "A.x" :~ var (qual "A" "x")+        ]+    , test "app"+        [ "A x" :~ var "A" @@ var "x"+        , "(+) x" :~ var "+" @@ var "x"+        , "A (B x)" :~ var "A" @@ 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"+        ]+    , test "op"+        [ "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 `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"))+        ]+    , 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"+        ]+    , test "literals"+        [ "\"abc\"" :~ stringTy "abc"+        , "123" :~ numTy 123+        ]+    , test "unit"+        [ "()" :~ unit ]+   , test "list"+        [ "[x]" :~ listTy (var "x")+        , "[]" :~ listPromotedTy []+        , "[x]" :~ listPromotedTy [var "x"]+        , "[y, z]" :~ listPromotedTy [var "y", var "z"]+        ]+    ]+  where+    test = testTypes dflags++exprsTest dflags = testGroup "Expr"+    [ test "var"+        [ "A" :~ var "A"+        , "x" :~ var "x"+        , "A.x" :~ var "A.x"+        , "x" :~ var (unqual "x")+        , "A.x" :~ var (qual "A" "x")+        ]+    , test "app"+        [ "A x" :~ var "A" @@ var "x"+        , "(+) x" :~ var "+" @@ var "x"+        , "A (B x)" :~ var "A" @@ 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 'x'" :~ var "A" @@ char 'x'+        , "A \"xyz\"" :~ var "A" @@ string "xyz"+        ]+    , test "op"+        [ "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 `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"))+        ]+    , test ":@@:"+        -- TODO: GHC puts extra space here.+        [ "  e :: t" :~ var "e" @::@ var "t" ]+    , test "unit"+        [ "()" :~ unit ]+    , test "list"+        [ "[]" :~ list []+        , "[]" :~ nil+        , "[x]" :~ list [var "x"]+        , "[y, z]" :~ list [var "y", var "z"]+        , "(:)" :~ cons+        , "(:) x y" :~ cons @@ var "x" @@ var "y"+        ]+    , test "tyApp"+        [ "x @a" :~ tyApp (var "x") (var "a")+        , "x @a @b" :~ tyApp (tyApp (var "x") (var "a")) (var "b")+        , "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"))+        ]+    ]+  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, y)\n  | test = (1, 2)\n  | otherwise = (2, 3)" :~+            patBind (tuple [var "x", var "y"])+                $ guardedRhs+                    [ var "test" `guard` tuple [int 1, int 2]+                        , var "otherwise" `guard` tuple [int 2, int 3]+                    ]+        , "z | Just y <- x, y = ()" :~+            patBind (var "z")+                $ guardedRhs+                    [guards+                        [ conP "Just" [var "y"] <-- var "x"+                        , stmt (var "y")+                        ]+                        unit+                    ]+        ]+    , test "funBind"+        [ "not True = False\nnot False = True" :~+             funBinds "not"+                [ matchRhs [var "True"] (var "False")+                , matchRhs [var "False"] (var "True")+                ]+        , "not x\n  | x = False\n  | otherwise = True" :~+            funBind "not"+                $ match [var "x"] $ guardedRhs+                    [ guard (var "x") (var "False")+                    , guard (var "otherwise") (var "True")+                    ]+        ]+    ]+  where+    test = testDecls dflags