Udate hsSyn AST to use Trees that Grow

Summary:
See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow

This commit prepares the ground for a full extensible AST, by replacing the type
parameter for the hsSyn data types with a set of indices into type families,

    data GhcPs -- ^ Index for GHC parser output
    data GhcRn -- ^ Index for GHC renamer output
    data GhcTc -- ^ Index for GHC typechecker output

These are now used instead of `RdrName`, `Name` and `Id`/`TcId`/`Var`

Where the original name type is required in a polymorphic context, this is
accessible via the IdP type family, defined as

    type family IdP p
    type instance IdP GhcPs = RdrName
    type instance IdP GhcRn = Name
    type instance IdP GhcTc = Id

These types are declared in the new 'hsSyn/HsExtension.hs' module.

To gain a better understanding of the extension mechanism, it has been applied
to `HsLit` only, also replacing the `SourceText` fields in them with extension
types.

To preserve extension generality, a type class is introduced to capture the
`SourceText` interface, which must be honoured by all of the extension points
which originally had a `SourceText`.  The class is defined as

    class HasSourceText a where
      -- Provide setters to mimic existing constructors
      noSourceText  :: a
      sourceText    :: String -> a

      setSourceText :: SourceText -> a
      getSourceText :: a -> SourceText

And the constraint is captured in `SourceTextX`, which is a constraint type
listing all the extension points that make use of the class.

Updating Haddock submodule to match.

Test Plan: ./validate

Reviewers: simonpj, shayan-najd, goldfire, austin, bgamari

Subscribers: rwbarton, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D3609

1 files changed, 34 insertions, 32 deletions

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 8234cccb5c..19bdba658f 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -134,7 +134,7 @@ data PmPat :: PatTy -> * where
             , pm_con_dicts   :: [EvVar]
             , pm_con_args    :: [PmPat t] } -> PmPat t
             -- For PmCon arguments' meaning see @ConPatOut@ in hsSyn/HsPat.hs
-  PmVar  :: { pm_var_id   :: Id    } -> PmPat t
+  PmVar  :: { pm_var_id   :: Id } -> PmPat t
   PmLit  :: { pm_lit_lit  :: PmLit } -> PmPat t -- See Note [Literals in PmPat]
   PmNLit :: { pm_lit_id   :: Id
             , pm_lit_not  :: [PmLit] } -> PmPat 'VA
@@ -254,9 +254,9 @@ instance Monoid PartialResult where
 data PmResult =
   PmResult {
       pmresultProvenance :: Provenance
-    , pmresultRedundant :: [Located [LPat Id]]
+    , pmresultRedundant :: [Located [LPat GhcTc]]
     , pmresultUncovered :: UncoveredCandidates
-    , pmresultInaccessible :: [Located [LPat Id]] }
+    , pmresultInaccessible :: [Located [LPat GhcTc]] }
 
 -- | Either a list of patterns that are not covered, or their type, in case we
 -- have no patterns at hand. Not having patterns at hand can arise when
@@ -289,7 +289,7 @@ uncoveredWithTy ty = PmResult FromBuiltin [] (TypeOfUncovered ty) []
 -}
 
 -- | Check a single pattern binding (let)
-checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM ()
+checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM ()
 checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do
   tracePmD "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])
   mb_pm_res <- tryM (getResult (checkSingle' locn var p))
@@ -298,7 +298,7 @@ checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do
     Right res -> dsPmWarn dflags ctxt res
 
 -- | Check a single pattern binding (let)
-checkSingle' :: SrcSpan -> Id -> Pat Id -> PmM PmResult
+checkSingle' :: SrcSpan -> Id -> Pat GhcTc -> PmM PmResult
 checkSingle' locn var p = do
   liftD resetPmIterDs -- set the iter-no to zero
   fam_insts <- liftD dsGetFamInstEnvs
@@ -316,7 +316,7 @@ checkSingle' locn var p = do
 
 -- | Check a matchgroup (case, functions, etc.)
 checkMatches :: DynFlags -> DsMatchContext
-             -> [Id] -> [LMatch Id (LHsExpr Id)] -> DsM ()
+             -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM ()
 checkMatches dflags ctxt vars matches = do
   tracePmD "checkMatches" (hang (vcat [ppr ctxt
                                , ppr vars
@@ -334,7 +334,7 @@ checkMatches dflags ctxt vars matches = do
 
 -- | Check a matchgroup (case, functions, etc.). To be called on a non-empty
 -- list of matches. For empty case expressions, use checkEmptyCase' instead.
-checkMatches' :: [Id] -> [LMatch Id (LHsExpr Id)] -> PmM PmResult
+checkMatches' :: [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> PmM PmResult
 checkMatches' vars matches
   | null matches = panic "checkMatches': EmptyCase"
   | otherwise = do
@@ -348,11 +348,11 @@ checkMatches' vars matches
                  , pmresultUncovered    = UncoveredPatterns us
                  , pmresultInaccessible = map hsLMatchToLPats ds }
   where
-    go :: [LMatch Id (LHsExpr Id)] -> Uncovered
+    go :: [LMatch GhcTc (LHsExpr GhcTc)] -> Uncovered
        -> PmM (Provenance
-              , [LMatch Id (LHsExpr Id)]
+              , [LMatch GhcTc (LHsExpr GhcTc)]
               , Uncovered
-              , [LMatch Id (LHsExpr Id)])
+              , [LMatch GhcTc (LHsExpr GhcTc)])
     go []     missing = return (mempty, [], missing, [])
     go (m:ms) missing = do
       tracePm "checMatches': go" (ppr m $$ ppr missing)
@@ -544,14 +544,14 @@ mkListPatVec ty xs ys = [PmCon { pm_con_con = RealDataCon consDataCon
 {-# INLINE mkListPatVec #-}
 
 -- | Create a (non-overloaded) literal pattern
-mkLitPattern :: HsLit -> Pattern
+mkLitPattern :: HsLit GhcTc -> Pattern
 mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit }
 {-# INLINE mkLitPattern #-}
 
 -- -----------------------------------------------------------------------
 -- * Transform (Pat Id) into of (PmPat Id)
 
-translatePat :: FamInstEnvs -> Pat Id -> DsM PatVec
+translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec
 translatePat fam_insts pat = case pat of
   WildPat ty  -> mkPmVars [ty]
   VarPat  id  -> return [PmVar (unLoc id)]
@@ -661,15 +661,16 @@ translatePat fam_insts pat = case pat of
 
 -- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs)
 translateNPat :: FamInstEnvs
-              -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> DsM PatVec
+              -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> Type
+              -> DsM PatVec
 translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty
   | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg
   = translatePat fam_insts (LitPat (HsString src s))
   | not type_change, isIntTy    ty, HsIntegral i <- val
   = translatePat fam_insts
                  (LitPat $ case mb_neg of
-                             Nothing -> HsInt i
-                             Just _  -> HsInt (negateIntegralLit i))
+                             Nothing -> HsInt def i
+                             Just _  -> HsInt def (negateIntegralLit i))
   | not type_change, isWordTy   ty, HsIntegral i <- val
   = translatePat fam_insts
                  (LitPat $ case mb_neg of
@@ -684,12 +685,12 @@ translateNPat _ ol mb_neg _
 
 -- | Translate a list of patterns (Note: each pattern is translated
 -- to a pattern vector but we do not concatenate the results).
-translatePatVec :: FamInstEnvs -> [Pat Id] -> DsM [PatVec]
+translatePatVec :: FamInstEnvs -> [Pat GhcTc] -> DsM [PatVec]
 translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats
 
 -- | Translate a constructor pattern
 translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar]
-                   -> ConLike -> HsConPatDetails Id -> DsM PatVec
+                   -> ConLike -> HsConPatDetails GhcTc -> DsM PatVec
 translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps)
   = concat <$> translatePatVec fam_insts (map unLoc ps)
 translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2)
@@ -744,13 +745,14 @@ translateConPatVec fam_insts  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))
       | otherwise = subsetOf (x:xs) ys
 
 -- Translate a single match
-translateMatch :: FamInstEnvs -> LMatch Id (LHsExpr Id) -> DsM (PatVec,[PatVec])
+translateMatch :: FamInstEnvs -> LMatch GhcTc (LHsExpr GhcTc)
+               -> DsM (PatVec,[PatVec])
 translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do
   pats'   <- concat <$> translatePatVec fam_insts pats
   guards' <- mapM (translateGuards fam_insts) guards
   return (pats', guards')
   where
-    extractGuards :: LGRHS Id (LHsExpr Id) -> [GuardStmt Id]
+    extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]
     extractGuards (L _ (GRHS gs _)) = map unLoc gs
 
     pats   = map unLoc lpats
@@ -760,7 +762,7 @@ translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do
 -- * Transform source guards (GuardStmt Id) to PmPats (Pattern)
 
 -- | Translate a list of guard statements to a pattern vector
-translateGuards :: FamInstEnvs -> [GuardStmt Id] -> DsM PatVec
+translateGuards :: FamInstEnvs -> [GuardStmt GhcTc] -> DsM PatVec
 translateGuards fam_insts guards = do
   all_guards <- concat <$> mapM (translateGuard fam_insts) guards
   return (replace_unhandled all_guards)
@@ -800,7 +802,7 @@ cantFailPattern (PmGrd pv _e)
 cantFailPattern _ = False
 
 -- | Translate a guard statement to Pattern
-translateGuard :: FamInstEnvs -> GuardStmt Id -> DsM PatVec
+translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM PatVec
 translateGuard fam_insts guard = case guard of
   BodyStmt   e _ _ _ -> translateBoolGuard e
   LetStmt      binds -> translateLet (unLoc binds)
@@ -812,17 +814,17 @@ translateGuard fam_insts guard = case guard of
   ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"
 
 -- | Translate let-bindings
-translateLet :: HsLocalBinds Id -> DsM PatVec
+translateLet :: HsLocalBinds GhcTc -> DsM PatVec
 translateLet _binds = return []
 
 -- | Translate a pattern guard
-translateBind :: FamInstEnvs -> LPat Id -> LHsExpr Id -> DsM PatVec
+translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM PatVec
 translateBind fam_insts (L _ p) e = do
   ps <- translatePat fam_insts p
   return [mkGuard ps (unLoc e)]
 
 -- | Translate a boolean guard
-translateBoolGuard :: LHsExpr Id -> DsM PatVec
+translateBoolGuard :: LHsExpr GhcTc -> DsM PatVec
 translateBoolGuard e
   | isJust (isTrueLHsExpr e) = return []
     -- The formal thing to do would be to generate (True <- True)
@@ -996,7 +998,7 @@ mkOneConFull x con = do
 -- * More smart constructors and fresh variable generation
 
 -- | Create a guard pattern
-mkGuard :: PatVec -> HsExpr Id -> Pattern
+mkGuard :: PatVec -> HsExpr GhcTc -> Pattern
 mkGuard pv e
   | all cantFailPattern pv = PmGrd pv expr
   | PmExprOther {} <- expr = fake_pat
@@ -1041,7 +1043,7 @@ mkPmId ty = getUniqueM >>= \unique ->
 -- | Generate a fresh term variable of a given and return it in two forms:
 -- * A variable pattern
 -- * A variable expression
-mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr Id)
+mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc)
 mkPmId2Forms ty = do
   x <- mkPmId ty
   return (PmVar x, noLoc (HsVar (noLoc x)))
@@ -1508,9 +1510,9 @@ these constraints.
 -- When we go deeper to check e.g. e1 we record two equalities:
 -- (x ~ y), where y is the initial uncovered when checking (p1; .. ; pn)
 -- and (x ~ p1).
-genCaseTmCs2 :: Maybe (LHsExpr Id) -- Scrutinee
-             -> [Pat Id]           -- LHS       (should have length 1)
-             -> [Id]               -- MatchVars (should have length 1)
+genCaseTmCs2 :: Maybe (LHsExpr GhcTc) -- Scrutinee
+             -> [Pat GhcTc]           -- LHS       (should have length 1)
+             -> [Id]                  -- MatchVars (should have length 1)
              -> DsM (Bag SimpleEq)
 genCaseTmCs2 Nothing _ _ = return emptyBag
 genCaseTmCs2 (Just scr) [p] [var] = do
@@ -1524,7 +1526,7 @@ genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase"
 --     case x of { matches }
 -- When checking matches we record that (x ~ y) where y is the initial
 -- uncovered. All matches will have to satisfy this equality.
-genCaseTmCs1 :: Maybe (LHsExpr Id) -> [Id] -> Bag SimpleEq
+genCaseTmCs1 :: Maybe (LHsExpr GhcTc) -> [Id] -> Bag SimpleEq
 genCaseTmCs1 Nothing     _    = emptyBag
 genCaseTmCs1 (Just scr) [var] = unitBag (var, lhsExprToPmExpr scr)
 genCaseTmCs1 _ _              = panic "genCaseTmCs1: HsCase"
@@ -1742,11 +1744,11 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
                                     \ pp -> ppr fun <+> pp)
              _                  -> (pprMatchContext kind, \ pp -> pp)
 
-ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
+ppr_pats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc
 ppr_pats kind pats
   = sep [sep (map ppr pats), matchSeparator kind, text "..."]
 
-ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat Id] -> SDoc
+ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat GhcTc] -> SDoc
 ppr_eqn prefixF kind eqn = prefixF (ppr_pats kind (map unLoc eqn))
 
 ppr_constraint :: (SDoc,[PmLit]) -> SDoc