parser/RdrHsSyn.hs

    --
    --  (c) The University of Glasgow 2002-2006
    --

    -- Functions over HsSyn specialised to RdrName.

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE TypeFamilies #-}
    {-# LANGUAGE MagicHash #-}

    module   RdrHsSyn (
            mkHsOpApp,
            mkHsIntegral, mkHsFractional, mkHsIsString,
            mkHsDo, mkSpliceDecl,
            mkRoleAnnotDecl,
            mkClassDecl,
            mkTyData, mkDataFamInst,
            mkTySynonym, mkTyFamInstEqn,
            mkTyFamInst,
            mkFamDecl, mkLHsSigType,
            splitCon, mkInlinePragma,
            mkPatSynMatchGroup,
            mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
            mkTyClD, mkInstD,
            mkRdrRecordCon, mkRdrRecordUpd,
            setRdrNameSpace,

            cvBindGroup,
            cvBindsAndSigs,
            cvTopDecls,
            placeHolderPunRhs,

            -- Stuff to do with Foreign declarations
            mkImport,
            parseCImport,
            mkExport,
            mkExtName,           -- RdrName -> CLabelString
            mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
            mkConDeclH98,
            mkATDefault,

            -- Bunch of functions in the parser monad for
            -- checking and constructing values
            checkBlockArguments,
            checkPrecP,           -- Int -> P Int
            checkContext,         -- HsType -> P HsContext
            checkInfixConstr,
            checkPattern,         -- HsExp -> P HsPat
            bang_RDR,
            checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
            checkMonadComp,       -- P (HsStmtContext RdrName)
            checkCommand,         -- LHsExpr RdrName -> P (LHsCmd RdrName)
            checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
            checkValSigLhs,
            checkDoAndIfThenElse,
            checkRecordSyntax,
            checkEmptyGADTs,
            parseErrorSDoc, hintBangPat,
            splitTilde,
            TyEl(..), mergeOps,

            -- Help with processing exports
            ImpExpSubSpec(..),
            ImpExpQcSpec(..),
            mkModuleImpExp,
            mkTypeImpExp,
            mkImpExpSubSpec,
            checkImportSpec,

            -- Warnings and errors
            warnStarIsType,
            failOpFewArgs,

            SumOrTuple (..), mkSumOrTuple

        ) where

    import GhcPrelude
    import HsSyn            -- Lots of it
    import Class            ( FunDep )
    import TyCon            ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
    import DataCon          ( DataCon, dataConTyCon )
    import ConLike          ( ConLike(..) )
    import CoAxiom          ( Role, fsFromRole )
    import RdrName
    import Name
    import BasicTypes
    import TcEvidence       ( idHsWrapper )
    import Lexer
    import Lexeme           ( isLexCon )
    import Type             ( TyThing(..) )
    import TysWiredIn       ( cTupleTyConName, tupleTyCon, tupleDataCon,
                              nilDataConName, nilDataConKey,
                              listTyConName, listTyConKey )
    import ForeignCall
    import PrelNames        ( forall_tv_RDR, eqTyCon_RDR, allNameStrings )
    import SrcLoc
    import Unique           ( hasKey )
    import OrdList          ( OrdList, fromOL )
    import Bag              ( emptyBag, consBag )
    import Outputable
    import FastString
    import Maybes
    import Util
    import ApiAnnotation
    import HsExtension      ( noExt )
    import Data.List
    import qualified GHC.LanguageExtensions as LangExt
    import DynFlags ( WarningFlag(..) )

    import Control.Monad
    import Text.ParserCombinators.ReadP as ReadP
    import Data.Char

    import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )

    #include "HsVersions.h"

    {- **********************************************************************

      Construction functions for Rdr stuff

      ********************************************************************* -}

    -- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and
    -- datacon by deriving them from the name of the class.  We fill in the names
    -- for the tycon and datacon corresponding to the class, by deriving them
    -- from the name of the class itself.  This saves recording the names in the
    -- interface file (which would be equally good).

    -- Similarly for mkConDecl, mkClassOpSig and default-method names.

    --         *** See Note [The Naming story] in HsDecls ****

    mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
    mkTyClD (L loc d) = L loc (TyClD noExt d)

    mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
    mkInstD (L loc d) = L loc (InstD noExt d)

    mkClassDecl :: SrcSpan
                -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
                -> Located (a,[Located (FunDep (Located RdrName))])
                -> OrdList (LHsDecl GhcPs)
                -> P (LTyClDecl GhcPs)

    mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
      = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
           ; let cxt = fromMaybe (noLoc []) mcxt
           ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
           ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
           ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams
           ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
           ; return (L loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
                                      , tcdLName = cls, tcdTyVars = tyvars
                                      , tcdFixity = fixity
                                      , tcdFDs = snd (unLoc fds)
                                      , tcdSigs = mkClassOpSigs sigs
                                      , tcdMeths = binds
                                      , tcdATs = ats, tcdATDefs = at_defs
                                      , tcdDocs  = docs })) }

    mkATDefault :: LTyFamInstDecl GhcPs
                -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs)
    -- Take a type-family instance declaration and turn it into
    -- a type-family default equation for a class declaration
    -- We parse things as the former and use this function to convert to the latter
    --
    -- We use the Either monad because this also called
    -- from Convert.hs
    mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
          | FamEqn { feqn_tycon = tc, feqn_pats = pats, feqn_fixity = fixity
                   , feqn_rhs = rhs } <- e
          = do { tvs <- checkTyVars (text "default") equalsDots tc pats
               ; return (L loc (FamEqn { feqn_ext    = noExt
                                       , feqn_tycon  = tc
                                       , feqn_pats   = tvs
                                       , feqn_fixity = fixity
                                       , feqn_rhs    = rhs })) }
    mkATDefault (L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
    mkATDefault (L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"

    mkTyData :: SrcSpan
             -> NewOrData
             -> Maybe (Located CType)
             -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
             -> Maybe (LHsKind GhcPs)
             -> [LConDecl GhcPs]
             -> HsDeriving GhcPs
             -> P (LTyClDecl GhcPs)
    mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
      = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
           ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
           ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
           ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
           ; return (L loc (DataDecl { tcdDExt = noExt,
                                       tcdLName = tc, tcdTyVars = tyvars,
                                       tcdFixity = fixity,
                                       tcdDataDefn = defn })) }

    mkDataDefn :: NewOrData
               -> Maybe (Located CType)
               -> Maybe (LHsContext GhcPs)
               -> Maybe (LHsKind GhcPs)
               -> [LConDecl GhcPs]
               -> HsDeriving GhcPs
               -> P (HsDataDefn GhcPs)
    mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
      = do { checkDatatypeContext mcxt
           ; let cxt = fromMaybe (noLoc []) mcxt
           ; return (HsDataDefn { dd_ext = noExt
                                , dd_ND = new_or_data, dd_cType = cType
                                , dd_ctxt = cxt
                                , dd_cons = data_cons
                                , dd_kindSig = ksig
                                , dd_derivs = maybe_deriv }) }

    mkTySynonym :: SrcSpan
                -> LHsType GhcPs  -- LHS
                -> LHsType GhcPs  -- RHS
                -> P (LTyClDecl GhcPs)
    mkTySynonym loc lhs rhs
      = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
           ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
           ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams
           ; return (L loc (SynDecl { tcdSExt = noExt
                                    , tcdLName = tc, tcdTyVars = tyvars
                                    , tcdFixity = fixity
                                    , tcdRhs = rhs })) }

    mkTyFamInstEqn :: LHsType GhcPs
                   -> LHsType GhcPs
                   -> P (TyFamInstEqn GhcPs,[AddAnn])
    mkTyFamInstEqn lhs rhs
      = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
           ; return (mkHsImplicitBndrs
                      (FamEqn { feqn_ext    = noExt
                              , feqn_tycon  = tc
                              , feqn_pats   = tparams
                              , feqn_fixity = fixity
                              , feqn_rhs    = rhs }),
                     ann) }

    mkDataFamInst :: SrcSpan
                  -> NewOrData
                  -> Maybe (Located CType)
                  -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
                  -> Maybe (LHsKind GhcPs)
                  -> [LConDecl GhcPs]
                  -> HsDeriving GhcPs
                  -> P (LInstDecl GhcPs)
    mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
      = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
           ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
           ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
           ; return (L loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs
                      (FamEqn { feqn_ext    = noExt
                              , feqn_tycon  = tc
                              , feqn_pats   = tparams
                              , feqn_fixity = fixity
                              , feqn_rhs    = defn }))))) }

    mkTyFamInst :: SrcSpan
                -> TyFamInstEqn GhcPs
                -> P (LInstDecl GhcPs)
    mkTyFamInst loc eqn
      = return (L loc (TyFamInstD noExt (TyFamInstDecl eqn)))

    mkFamDecl :: SrcSpan
              -> FamilyInfo GhcPs
              -> LHsType GhcPs                   -- LHS
              -> Located (FamilyResultSig GhcPs) -- Optional result signature
              -> Maybe (LInjectivityAnn GhcPs)   -- Injectivity annotation
              -> P (LTyClDecl GhcPs)
    mkFamDecl loc info lhs ksig injAnn
      = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
           ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
           ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
           ; return (L loc (FamDecl noExt (FamilyDecl
                                               { fdExt       = noExt
                                               , fdInfo      = info, fdLName = tc
                                               , fdTyVars    = tyvars
                                               , fdFixity    = fixity
                                               , fdResultSig = ksig
                                               , fdInjectivityAnn = injAnn }))) }
      where
        equals_or_where = case info of
                            DataFamily          -> empty
                            OpenTypeFamily      -> empty
                            ClosedTypeFamily {} -> whereDots

    mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
    -- If the user wrote
    --      [pads| ... ]   then return a QuasiQuoteD
    --      $(e)           then return a SpliceD
    -- but if she wrote, say,
    --      f x            then behave as if she'd written $(f x)
    --                     ie a SpliceD
    --
    -- Typed splices are not allowed at the top level, thus we do not represent them
    -- as spliced declaration.  See #10945
    mkSpliceDecl lexpr@(L loc expr)
      | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
      = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)

      | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
      = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)

      | otherwise
      = SpliceD noExt (SpliceDecl noExt (L loc (mkUntypedSplice NoParens lexpr))
                                  ImplicitSplice)

    mkRoleAnnotDecl :: SrcSpan
                    -> Located RdrName                -- type being annotated
                    -> [Located (Maybe FastString)]      -- roles
                    -> P (LRoleAnnotDecl GhcPs)
    mkRoleAnnotDecl loc tycon roles
      = do { roles' <- mapM parse_role roles
           ; return $ L loc $ RoleAnnotDecl noExt tycon roles' }
      where
        role_data_type = dataTypeOf (undefined :: Role)
        all_roles = map fromConstr $ dataTypeConstrs role_data_type
        possible_roles = [(fsFromRole role, role) | role <- all_roles]

        parse_role (L loc_role Nothing) = return $ L loc_role Nothing
        parse_role (L loc_role (Just role))
          = case lookup role possible_roles of
              Just found_role -> return $ L loc_role $ Just found_role
              Nothing         ->
                let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in
                parseErrorSDoc loc_role
                  (text "Illegal role name" <+> quotes (ppr role) $$
                   suggestions nearby)

        suggestions []   = empty
        suggestions [r]  = text "Perhaps you meant" <+> quotes (ppr r)
          -- will this last case ever happen??
        suggestions list = hang (text "Perhaps you meant one of these:")
                           2 (pprWithCommas (quotes . ppr) list)

    {- **********************************************************************

      #cvBinds-etc# Converting to @HsBinds@, etc.

      ********************************************************************* -}

    -- | Function definitions are restructured here. Each is assumed to be recursive
    -- initially, and non recursive definitions are discovered by the dependency
    -- analyser.

    --  | Groups together bindings for a single function
    cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
    cvTopDecls decls = go (fromOL decls)
      where
        go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
        go []                     = []
        go (L l (ValD x b) : ds)  = L l' (ValD x b') : go ds'
                                where (L l' b', ds') = getMonoBind (L l b) ds
        go (d : ds)               = d : go ds

    -- Declaration list may only contain value bindings and signatures.
    cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
    cvBindGroup binding
      = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding
           ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
             return $ ValBinds noExt mbs sigs }

    cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
      -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
              , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])
    -- Input decls contain just value bindings and signatures
    -- and in case of class or instance declarations also
    -- associated type declarations. They might also contain Haddock comments.
    cvBindsAndSigs fb = go (fromOL fb)
      where
        go []              = return (emptyBag, [], [], [], [], [])
        go (L l (ValD _ b) : ds)
          = do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
               ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
          where
            (b', ds') = getMonoBind (L l b) ds
        go (L l decl : ds)
          = do { (bs, ss, ts, tfis, dfis, docs) <- go ds
               ; case decl of
                   SigD _ s
                     -> return (bs, L l s : ss, ts, tfis, dfis, docs)
                   TyClD _ (FamDecl _ t)
                     -> return (bs, ss, L l t : ts, tfis, dfis, docs)
                   InstD _ (TyFamInstD { tfid_inst = tfi })
                     -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
                   InstD _ (DataFamInstD { dfid_inst = dfi })
                     -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
                   DocD _ d
                     -> return (bs, ss, ts, tfis, dfis, L l d : docs)
                   SpliceD _ d
                     -> parseErrorSDoc l $
                        hang (text "Declaration splices are allowed only" <+>
                              text "at the top level:")
                           2 (ppr d)
                   _ -> pprPanic "cvBindsAndSigs" (ppr decl) }

    -----------------------------------------------------------------------------
    -- Group function bindings into equation groups

    getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
      -> (LHsBind GhcPs, [LHsDecl GhcPs])
    -- Suppose      (b',ds') = getMonoBind b ds
    --      ds is a list of parsed bindings
    --      b is a MonoBinds that has just been read off the front

    -- Then b' is the result of grouping more equations from ds that
    -- belong with b into a single MonoBinds, and ds' is the depleted
    -- list of parsed bindings.
    --
    -- All Haddock comments between equations inside the group are
    -- discarded.
    --
    -- No AndMonoBinds or EmptyMonoBinds here; just single equations

    getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
                                   fun_matches
                                     = MG { mg_alts = L _ mtchs1 } })) binds
      | has_args mtchs1
      = go mtchs1 loc1 binds []
      where
        go mtchs loc
           (L loc2 (ValD _ (FunBind { fun_id = L _ f2,
                                      fun_matches
                                        = MG { mg_alts = L _ mtchs2 } })) : binds) _
            | f1 == f2 = go (mtchs2 ++ mtchs)
                            (combineSrcSpans loc loc2) binds []
        go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls
            = let doc_decls' = doc_decl : doc_decls
              in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
        go mtchs loc binds doc_decls
            = ( L loc (makeFunBind fun_id1 (reverse mtchs))
              , (reverse doc_decls) ++ binds)
            -- Reverse the final matches, to get it back in the right order
            -- Do the same thing with the trailing doc comments

    getMonoBind bind binds = (bind, binds)

    has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
    has_args []                                    = panic "RdrHsSyn:has_args"
    has_args ((L _ (Match { m_pats = args })) : _) = not (null args)
            -- Don't group together FunBinds if they have
            -- no arguments.  This is necessary now that variable bindings
            -- with no arguments are now treated as FunBinds rather
            -- than pattern bindings (tests/rename/should_fail/rnfail002).
    has_args ((L _ (XMatch _)) : _) = panic "has_args"

    {- **********************************************************************

      #PrefixToHS-utils# Utilities for conversion

      ********************************************************************* -}

    {- Note [Parsing data constructors is hard]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We parse the RHS of the constructor declaration
         data T = C t1 t2
    as a btype_no_ops (treating C as a type constructor) and then convert C to be
    a data constructor.  Reason: it might continue like this:
         data T = C t1 t2 :% D Int
    in which case C really /would/ be a type constructor.  We can't resolve this
    ambiguity till we come across the constructor oprerator :% (or not, more usually)

    So the plan is:

    * Parse the data constructor declration as a type (actually btype_no_ops)

    * Use 'splitCon' to rejig it into the data constructor, the args, and possibly
      extract a docstring for the constructor

    * In doing so, we use 'tyConToDataCon' to convert the RdrName for
      the data con, which has been parsed as a tycon, back to a datacon.
      This is more than just adjusting the name space; for operators we
      need to check that it begins with a colon.  E.g.
         data T = (+++)
      will parse ok (since tycons can be operators), but we should reject
      it (Trac #12051).

    'splitCon' takes a reversed list @apps@ of types as input, such that
    @foldl1 mkHsAppTy (reverse apps)@ yields the original type. This is because
    this is easy for the parser to produce and we avoid the overhead of unrolling
    'HsAppTy'.

    -}

    splitCon :: [LHsType GhcPs]
          -> P ( Located RdrName         -- constructor name
               , HsConDeclDetails GhcPs  -- constructor field information
               , Maybe LHsDocString      -- docstring to go on the constructor
               )
    -- See Note [Parsing data constructors is hard]
    -- This gets given a "type" that should look like
    --      C Int Bool
    -- or   C { x::Int, y::Bool }
    -- and returns the pieces
    splitCon apps
     = split apps' []
     where
       oneDoc = [ () | L _ (HsDocTy{}) <- apps ] `lengthIs` 1
       ty = foldl1 mkHsAppTy (reverse apps)

       -- the trailing doc, if any, can be extracted first
       (apps', trailing_doc)
         = case apps of
             L _ (HsDocTy _ t ds) : ts | oneDoc -> (t : ts, Just ds)
             ts -> (ts, Nothing)

       -- A comment on the constructor is handled a bit differently - it doesn't
       -- remain an 'HsDocTy', but gets lifted out and returned as the third
       -- element of the tuple.
       split [ L _ (HsDocTy _ con con_doc) ] ts = do
         (data_con, con_details, con_doc') <- split [con] ts
         return (data_con, con_details, con_doc' `mplus` Just con_doc)
       split [ L l (HsTyVar _ _ (L _ tc)) ] ts = do
         data_con <- tyConToDataCon l tc
         return (data_con, mk_rest ts, trailing_doc)
       split [ L l (HsTupleTy _ HsBoxedOrConstraintTuple ts) ] []
         = return ( L l (getRdrName (tupleDataCon Boxed (length ts)))
                  , PrefixCon ts
                  , trailing_doc
                  )
       split [ L l _ ] _ = parseErrorSDoc l (text msg <+> ppr ty)
         where msg = "Cannot parse data constructor in a data/newtype declaration:"
       split (u : us) ts = split us (u : ts)
       split _ _ = panic "RdrHsSyn:splitCon"

       mk_rest [L _ (HsDocTy _ t@(L _ HsRecTy{}) _)] = mk_rest [t]
       mk_rest [L l (HsRecTy _ flds)] = RecCon (L l flds)
       mk_rest ts                     = PrefixCon ts

    tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
    -- See Note [Parsing data constructors is hard]
    -- Data constructor RHSs are parsed as types
    tyConToDataCon loc tc
      | isTcOcc occ
      , isLexCon (occNameFS occ)
      = return (L loc (setRdrNameSpace tc srcDataName))

      | otherwise
      = parseErrorSDoc loc (msg $$ extra)
      where
        occ = rdrNameOcc tc

        msg = text "Not a data constructor:" <+> quotes (ppr tc)
        extra | tc == forall_tv_RDR
              = text "Perhaps you intended to use ExistentialQuantification"
              | otherwise = empty

    -- | Split a type to extract the trailing doc string (if there is one) from a
    -- type produced by the 'btype_no_ops' production.
    splitDocTy :: LHsType GhcPs -> (LHsType GhcPs, Maybe LHsDocString)
    splitDocTy (L l (HsAppTy x t1 t2)) = (L l (HsAppTy x t1 t2'), ds)
      where ~(t2', ds) = splitDocTy t2
    splitDocTy (L _ (HsDocTy _ ty ds)) = (ty, Just ds)
    splitDocTy ty = (ty, Nothing)

    -- | Given a type that is a field to an infix data constructor, try to split
    -- off a trailing docstring on the type, and check that there are no other
    -- docstrings.
    checkInfixConstr :: LHsType GhcPs -> P (LHsType GhcPs, Maybe LHsDocString)
    checkInfixConstr ty = checkNoDocs msg ty' *> pure (ty', doc_string)
      where (ty', doc_string) = splitDocTy ty
            msg = text "infix constructor field"

    mkPatSynMatchGroup :: Located RdrName
                       -> Located (OrdList (LHsDecl GhcPs))
                       -> P (MatchGroup GhcPs (LHsExpr GhcPs))
    mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
        do { matches <- mapM fromDecl (fromOL decls)
           ; when (null matches) (wrongNumberErr loc)
           ; return $ mkMatchGroup FromSource matches }
      where
        fromDecl (L loc decl@(ValD _ (PatBind _
                                       pat@(L _ (ConPatIn ln@(L _ name) details))
                                       rhs _))) =
            do { unless (name == patsyn_name) $
                   wrongNameBindingErr loc decl
               ; match <- case details of
                   PrefixCon pats -> return $ Match { m_ext = noExt
                                                    , m_ctxt = ctxt, m_pats = pats
                                                    , m_grhss = rhs }
                       where
                         ctxt = FunRhs { mc_fun = ln, mc_fixity = Prefix, mc_strictness = NoSrcStrict }

                   InfixCon p1 p2 -> return $ Match { m_ext = noExt
                                                    , m_ctxt = ctxt
                                                    , m_pats = [p1, p2]
                                                    , m_grhss = rhs }
                       where
                         ctxt = FunRhs { mc_fun = ln, mc_fixity = Infix, mc_strictness = NoSrcStrict }

                   RecCon{} -> recordPatSynErr loc pat
               ; return $ L loc match }
        fromDecl (L loc decl) = extraDeclErr loc decl

        extraDeclErr loc decl =
            parseErrorSDoc loc $
            text "pattern synonym 'where' clause must contain a single binding:" $$
            ppr decl

        wrongNameBindingErr loc decl =
            parseErrorSDoc loc $
            text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
            quotes (ppr patsyn_name) $$ ppr decl

        wrongNumberErr loc =
          parseErrorSDoc loc $
          text "pattern synonym 'where' clause cannot be empty" $$
          text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)

    recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
    recordPatSynErr loc pat =
        parseErrorSDoc loc $
        text "record syntax not supported for pattern synonym declarations:" $$
        ppr pat

    mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
                    -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
                    -> ConDecl GhcPs

    mkConDeclH98 name mb_forall mb_cxt args
      = ConDeclH98 { con_ext    = noExt
                   , con_name   = name
                   , con_forall = noLoc $ isJust mb_forall
                   , con_ex_tvs = mb_forall `orElse` []
                   , con_mb_cxt = mb_cxt
                   , con_args   = args'
                   , con_doc    = Nothing }
      where
        args' = nudgeHsSrcBangs args

    mkGadtDecl :: [Located RdrName]
               -> LHsType GhcPs     -- Always a HsForAllTy
               -> (ConDecl GhcPs, [AddAnn])
    mkGadtDecl names ty
      = (ConDeclGADT { con_g_ext  = noExt
                     , con_names  = names
                     , con_forall = L l $ isLHsForAllTy ty'
                     , con_qvars  = mkHsQTvs tvs
                     , con_mb_cxt = mcxt
                     , con_args   = args'
                     , con_res_ty = res_ty
                     , con_doc    = Nothing }
        , anns1 ++ anns2)
      where
        (ty'@(L l _),anns1) = peel_parens ty []
        (tvs, rho) = splitLHsForAllTy ty'
        (mcxt, tau, anns2) = split_rho rho []

        split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
                                           = (Just cxt, tau, ann)
        split_rho (L l (HsParTy _ ty)) ann = split_rho ty (ann++mkParensApiAnn l)
        split_rho tau                  ann = (Nothing, tau, ann)

        (args, res_ty) = split_tau tau
        args' = nudgeHsSrcBangs args

        -- See Note [GADT abstract syntax] in HsDecls
        split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty))
                                       = (RecCon (L loc rf), res_ty)
        split_tau tau                  = (PrefixCon [], tau)

        peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty
                                                           (ann++mkParensApiAnn l)
        peel_parens ty                   ann = (ty, ann)

    nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
    -- ^ This function ensures that fields with strictness or packedness
    -- annotations put these annotations on an outer 'HsBangTy'.
    --
    -- The problem is that in the parser, strictness and packedness annotations
    -- bind more tightly that docstrings. However, the expectation downstream of
    -- the parser (by functions such as 'getBangType' and 'getBangStrictness')
    -- is that docstrings bind more tightly so that 'HsBangTy' may end up as the
    -- top-level type.
    --
    -- See #15206
    nudgeHsSrcBangs details
      = case details of
          PrefixCon as -> PrefixCon (map go as)
          RecCon r -> RecCon r
          InfixCon a1 a2 -> InfixCon (go a1) (go a2)
      where
        go (L l (HsDocTy _ (L _ (HsBangTy _ s lty)) lds)) =
          L l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds)))
        go lty = lty

    setRdrNameSpace :: RdrName -> NameSpace -> RdrName
    -- ^ This rather gruesome function is used mainly by the parser.
    -- When parsing:
    --
    -- > data T a = T | T1 Int
    --
    -- we parse the data constructors as /types/ because of parser ambiguities,
    -- so then we need to change the /type constr/ to a /data constr/
    --
    -- The exact-name case /can/ occur when parsing:
    --
    -- > data [] a = [] | a : [a]
    --
    -- For the exact-name case we return an original name.
    setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
    setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
    setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
    setRdrNameSpace (Exact n)    ns
      | Just thing <- wiredInNameTyThing_maybe n
      = setWiredInNameSpace thing ns
        -- Preserve Exact Names for wired-in things,
        -- notably tuples and lists

      | isExternalName n
      = Orig (nameModule n) occ

      | otherwise   -- This can happen when quoting and then
                    -- splicing a fixity declaration for a type
      = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))
      where
        occ = setOccNameSpace ns (nameOccName n)

    setWiredInNameSpace :: TyThing -> NameSpace -> RdrName
    setWiredInNameSpace (ATyCon tc) ns
      | isDataConNameSpace ns
      = ty_con_data_con tc
      | isTcClsNameSpace ns
      = Exact (getName tc)      -- No-op

    setWiredInNameSpace (AConLike (RealDataCon dc)) ns
      | isTcClsNameSpace ns
      = data_con_ty_con dc
      | isDataConNameSpace ns
      = Exact (getName dc)      -- No-op

    setWiredInNameSpace thing ns
      = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)

    ty_con_data_con :: TyCon -> RdrName
    ty_con_data_con tc
      | isTupleTyCon tc
      , Just dc <- tyConSingleDataCon_maybe tc
      = Exact (getName dc)

      | tc `hasKey` listTyConKey
      = Exact nilDataConName

      | otherwise  -- See Note [setRdrNameSpace for wired-in names]
      = Unqual (setOccNameSpace srcDataName (getOccName tc))

    data_con_ty_con :: DataCon -> RdrName
    data_con_ty_con dc
      | let tc = dataConTyCon dc
      , isTupleTyCon tc
      = Exact (getName tc)

      | dc `hasKey` nilDataConKey
      = Exact listTyConName

      | otherwise  -- See Note [setRdrNameSpace for wired-in names]
      = Unqual (setOccNameSpace tcClsName (getOccName dc))

    {- Note [setRdrNameSpace for wired-in names]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    In GHC.Types, which declares (:), we have
      infixr 5 :
    The ambiguity about which ":" is meant is resolved by parsing it as a
    data constructor, but then using dataTcOccs to try the type constructor too;
    and that in turn calls setRdrNameSpace to change the name-space of ":" to
    tcClsName.  There isn't a corresponding ":" type constructor, but it's painful
    to make setRdrNameSpace partial, so we just make an Unqual name instead. It
    really doesn't matter!
    -}

    checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
                 -> P (LHsQTyVars GhcPs)
    -- Same as checkTyVars, but in the P monad
    checkTyVarsP pp_what equals_or_where tc tparms
      = eitherToP $ checkTyVars pp_what equals_or_where tc tparms

    eitherToP :: Either (SrcSpan, SDoc) a -> P a
    -- Adapts the Either monad to the P monad
    eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
    eitherToP (Right thing)     = return thing

    checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
                -> Either (SrcSpan, SDoc) (LHsQTyVars GhcPs)
    -- Check whether the given list of type parameters are all type variables
    -- (possibly with a kind signature)
    -- We use the Either monad because it's also called (via mkATDefault) from
    -- Convert.hs
    checkTyVars pp_what equals_or_where tc tparms
      = do { tvs <- mapM chk tparms
           ; return (mkHsQTvs tvs) }
      where
        chk (L _ (HsParTy _ ty)) = chk ty

            -- Check that the name space is correct!
        chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k))
            | isRdrTyVar tv    = return (L l (KindedTyVar noExt (L lv tv) k))
        chk (L l (HsTyVar _ _ (L ltv tv)))
            | isRdrTyVar tv    = return (L l (UserTyVar noExt (L ltv tv)))
        chk t@(L loc _)
            = Left (loc,
                    vcat [ text "Unexpected type" <+> quotes (ppr t)
                         , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)
                         , vcat[ (text "A" <+> pp_what <+> ptext (sLit "declaration should have form"))
                         , nest 2 (pp_what <+> ppr tc
                                           <+> hsep (map text (takeList tparms allNameStrings))
                                           <+> equals_or_where) ] ])

    whereDots, equalsDots :: SDoc
    -- Second argument to checkTyVars
    whereDots  = text "where ..."
    equalsDots = text "= ..."

    checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
    checkDatatypeContext Nothing = return ()
    checkDatatypeContext (Just (L loc c))
        = do allowed <- extension datatypeContextsEnabled
             unless allowed $
                 parseErrorSDoc loc
                     (text "Illegal datatype context (use DatatypeContexts):" <+>
                      pprHsContext c)

    checkRecordSyntax :: Outputable a => Located a -> P (Located a)
    checkRecordSyntax lr@(L loc r)
        = do allowed <- extension traditionalRecordSyntaxEnabled
             if allowed
                 then return lr
                 else parseErrorSDoc loc
                          (text "Illegal record syntax (use TraditionalRecordSyntax):" <+>
                           ppr r)

    -- | Check if the gadt_constrlist is empty. Only raise parse error for
    -- `data T where` to avoid affecting existing error message, see #8258.
    checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
                    -> P (Located ([AddAnn], [LConDecl GhcPs]))
    checkEmptyGADTs gadts@(L span (_, []))               -- Empty GADT declaration.
        = do opts <- fmap options getPState
             if LangExt.GADTSyntax `extopt` opts         -- GADTs implies GADTSyntax
                then return gadts
                else parseErrorSDoc span $ vcat
                  [ text "Illegal keyword 'where' in data declaration"
                  , text "Perhaps you intended to use GADTs or a similar language"
                  , text "extension to enable syntax: data T where"
                  ]
    checkEmptyGADTs gadts = return gadts              -- Ordinary GADT declaration.

    checkTyClHdr :: Bool               -- True  <=> class header
                                       -- False <=> type header
                 -> LHsType GhcPs
                 -> P (Located RdrName,      -- the head symbol (type or class name)
                       [LHsType GhcPs],      -- parameters of head symbol
                       LexicalFixity,        -- the declaration is in infix format
                       [AddAnn]) -- API Annotation for HsParTy when stripping parens
    -- Well-formedness check and decomposition of type and class heads.
    -- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
    --              Int :*: Bool   into    (:*:, [Int, Bool])
    -- returning the pieces
    checkTyClHdr is_cls ty
      = goL ty [] [] Prefix
      where
        goL (L l ty) acc ann fix = go l ty acc ann fix

        -- workaround to define '*' despite StarIsType
        go _ (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix
          = do { warnStarBndr l
               ; let name = mkOccName tcClsName (if isUni then "★" else "*")
               ; return (L l (Unqual name), acc, fix, ann) }

        go l (HsTyVar _ _ (L _ tc)) acc ann fix
          | isRdrTc tc               = return (L l tc, acc, fix, ann)
        go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix
          | isRdrTc tc               = return (ltc, t1:t2:acc, Infix, ann)
        go l (HsParTy _ ty)    acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix
        go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix

        go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
          = return (L l (nameRdrName tup_name), ts, fix, ann)
          where
            arity = length ts
            tup_name | is_cls    = cTupleTyConName arity
                     | otherwise = getName (tupleTyCon Boxed arity)
                     -- See Note [Unit tuples] in HsTypes  (TODO: is this still relevant?)
        go l _ _ _ _
          = parseErrorSDoc l (text "Malformed head of type or class declaration:"
                              <+> ppr ty)

    -- | Yield a parse error if we have a function applied directly to a do block
    -- etc. and BlockArguments is not enabled.
    checkBlockArguments :: LHsExpr GhcPs -> P ()
    checkBlockArguments expr = case unLoc expr of
        HsDo _ DoExpr _ -> check "do block"
        HsDo _ MDoExpr _ -> check "mdo block"
        HsLam {} -> check "lambda expression"
        HsCase {} -> check "case expression"
        HsLamCase {} -> check "lambda-case expression"
        HsLet {} -> check "let expression"
        HsIf {} -> check "if expression"
        HsProc {} -> check "proc expression"
        _ -> return ()
      where
        check element = do
          pState <- getPState
          unless (extopt LangExt.BlockArguments (options pState)) $
            parseErrorSDoc (getLoc expr) $
              text "Unexpected " <> text element <> text " in function application:"
               $$ nest 4 (ppr expr)
               $$ text "You could write it with parentheses"
               $$ text "Or perhaps you meant to enable BlockArguments?"

    -- | Validate the context constraints and break up a context into a list
    -- of predicates.
    --
    -- @
    --     (Eq a, Ord b)        -->  [Eq a, Ord b]
    --     Eq a                 -->  [Eq a]
    --     (Eq a)               -->  [Eq a]
    --     (((Eq a)))           -->  [Eq a]
    -- @
    checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
    checkContext (L l orig_t)
      = check [] (L l orig_t)
     where
      check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))
        -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
        -- be used as context constraints.
        = return (anns ++ mkParensApiAnn lp,L l ts)                -- Ditto ()

      check anns (L lp1 (HsParTy _ ty))
                                      -- to be sure HsParTy doesn't get into the way
           = check anns' ty
             where anns' = if l == lp1 then anns
                                       else (anns ++ mkParensApiAnn lp1)

      -- no need for anns, returning original
      check _anns t = checkNoDocs msg t *> return ([],L l [L l orig_t])

      msg = text "data constructor context"

    -- | Check recursively if there are any 'HsDocTy's in the given type.
    -- This only works on a subset of types produced by 'btype_no_ops'
    checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
    checkNoDocs msg ty = go ty
      where
        go (L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
        go (L l (HsDocTy _ t ds)) = parseErrorSDoc l $ hsep
                                      [ text "Unexpected haddock", quotes (ppr ds)
                                      , text "on", msg, quotes (ppr t) ]
        go _ = pure ()

    -- -------------------------------------------------------------------------
    -- Checking Patterns.

    -- We parse patterns as expressions and check for valid patterns below,
    -- converting the expression into a pattern at the same time.

    checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
    checkPattern msg e = checkLPat msg e

    checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
    checkPatterns msg es = mapM (checkPattern msg) es

    checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
    checkLPat msg e@(L l _) = checkPat msg l e []

    checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
             -> P (LPat GhcPs)
    checkPat _ loc (L l e@(HsVar _ (L _ c))) args
      | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
      | not (null args) && patIsRec c =
          patFail (text "Perhaps you intended to use RecursiveDo") l e
    checkPat msg loc e args     -- OK to let this happen even if bang-patterns
                            -- are not enabled, because there is no valid
                            -- non-bang-pattern parse of (C ! e)
      | Just (e', args') <- splitBang e
      = do  { args'' <- checkPatterns msg args'
            ; checkPat msg loc e' (args'' ++ args) }
    checkPat msg loc (L _ (HsApp _ f e)) args
      = do p <- checkLPat msg e
           checkPat msg loc f (p : args)
    checkPat msg loc (L _ e) []
      = do p <- checkAPat msg loc e
           return (L loc p)
    checkPat msg loc e _
      = patFail msg loc (unLoc e)

    checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs)
    checkAPat msg loc e0 = do
     pState <- getPState
     let opts = options pState
     case e0 of
       EWildPat _ -> return (WildPat noExt)
       HsVar _ x  -> return (VarPat noExt x)
       HsLit _ (HsStringPrim _ _) -- (#13260)
           -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0)

       HsLit _ l  -> return (LitPat noExt l)

       -- Overloaded numeric patterns (e.g. f 0 x = x)
       -- Negation is recorded separately, so that the literal is zero or +ve
       -- NB. Negative *primitive* literals are already handled by the lexer
       HsOverLit _ pos_lit          -> return (mkNPat (L loc pos_lit) Nothing)
       NegApp _ (L l (HsOverLit _ pos_lit)) _
                            -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))

       SectionR _ (L lb (HsVar _ (L _ bang))) e    -- (! x)
            | bang == bang_RDR
            -> do { hintBangPat loc e0
                  ; e' <- checkLPat msg e
                  ; addAnnotation loc AnnBang lb
                  ; return  (BangPat noExt e') }

       ELazyPat _ e         -> checkLPat msg e >>= (return . (LazyPat noExt))
       EAsPat _ n e         -> checkLPat msg e >>= (return . (AsPat noExt) n)
       -- view pattern is well-formed if the pattern is
       EViewPat _ expr patE -> checkLPat msg patE >>=
                                (return . (\p -> ViewPat noExt expr p))
       ExprWithTySig t e   -> do e <- checkLPat msg e
                                 return (SigPat t e)

       -- n+k patterns
       OpApp _ (L nloc (HsVar _ (L _ n))) (L _ (HsVar _ (L _ plus)))
               (L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}})))
                          | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
                          -> return (mkNPlusKPat (L nloc n) (L lloc lit))

       OpApp _ l (L cl (HsVar _ (L _ c))) r
         | isDataOcc (rdrNameOcc c) -> do
             l <- checkLPat msg l
             r <- checkLPat msg r
             return (ConPatIn (L cl c) (InfixCon l r))

       OpApp {}           -> patFail msg loc e0

       ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es
                                 return (ListPat noExt ps)

       HsPar _ e          -> checkLPat msg e >>= (return . (ParPat noExt))

       ExplicitTuple _ es b
         | all tupArgPresent es  -> do ps <- mapM (checkLPat msg)
                                                  [e | L _ (Present _ e) <- es]
                                       return (TuplePat noExt ps b)
         | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)

       ExplicitSum _ alt arity expr -> do
         p <- checkLPat msg expr
         return (SumPat noExt p alt arity)

       RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }
                            -> do fs <- mapM (checkPatField msg) fs
                                  return (ConPatIn c (RecCon (HsRecFields fs dd)))
       HsSpliceE _ s | not (isTypedSplice s)
                   -> return (SplicePat noExt s)
       _           -> patFail msg loc e0

    placeHolderPunRhs :: LHsExpr GhcPs
    -- The RHS of a punned record field will be filled in by the renamer
    -- It's better not to make it an error, in case we want to print it when debugging
    placeHolderPunRhs = noLoc (HsVar noExt (noLoc pun_RDR))

    plus_RDR, bang_RDR, pun_RDR :: RdrName
    plus_RDR = mkUnqual varName (fsLit "+") -- Hack
    bang_RDR = mkUnqual varName (fsLit "!") -- Hack
    pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")

    checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs)
                  -> P (LHsRecField GhcPs (LPat GhcPs))
    checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
                                     return (L l (fld { hsRecFieldArg = p }))

    patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
    patFail msg loc e = parseErrorSDoc loc err
        where err = text "Parse error in pattern:" <+> ppr e
                 $$ msg

    patIsRec :: RdrName -> Bool
    patIsRec e = e == mkUnqual varName (fsLit "rec")

    ---------------------------------------------------------------------------
    -- Check Equation Syntax

    checkValDef :: SDoc
                -> SrcStrictness
                -> LHsExpr GhcPs
                -> Maybe (LHsType GhcPs)
                -> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
                -> P ([AddAnn],HsBind GhcPs)

    checkValDef msg _strictness lhs (Just sig) grhss
            -- x :: ty = rhs  parses as a *pattern* binding
      = checkPatBind msg (L (combineLocs lhs sig)
                            (ExprWithTySig (mkLHsSigWcType sig) lhs)) grhss

    checkValDef msg strictness lhs Nothing g@(L l (_,grhss))
      = do  { mb_fun <- isFunLhs lhs
            ; case mb_fun of
                Just (fun, is_infix, pats, ann) ->
                  checkFunBind msg strictness ann (getLoc lhs)
                               fun is_infix pats (L l grhss)
                Nothing -> checkPatBind msg lhs g }

    checkFunBind :: SDoc
                 -> SrcStrictness
                 -> [AddAnn]
                 -> SrcSpan
                 -> Located RdrName
                 -> LexicalFixity
                 -> [LHsExpr GhcPs]
                 -> Located (GRHSs GhcPs (LHsExpr GhcPs))
                 -> P ([AddAnn],HsBind GhcPs)
    checkFunBind msg strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
      = do  ps <- checkPatterns msg pats
            let match_span = combineSrcSpans lhs_loc rhs_span
            -- Add back the annotations stripped from any HsPar values in the lhs
            -- mapM_ (\a -> a match_span) ann
            return (ann, makeFunBind fun
                      [L match_span (Match { m_ext = noExt
                                           , m_ctxt = FunRhs { mc_fun    = fun
                                                             , mc_fixity = is_infix
                                                             , mc_strictness = strictness }
                                           , m_pats = ps
                                           , m_grhss = grhss })])
            -- The span of the match covers the entire equation.
            -- That isn't quite right, but it'll do for now.

    makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
                -> HsBind GhcPs
    -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
    makeFunBind fn ms
      = FunBind { fun_ext = noExt,
                  fun_id = fn,
                  fun_matches = mkMatchGroup FromSource ms,
                  fun_co_fn = idHsWrapper,
                  fun_tick = [] }

    checkPatBind :: SDoc
                 -> LHsExpr GhcPs
                 -> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
                 -> P ([AddAnn],HsBind GhcPs)
    checkPatBind msg lhs (L _ (_,grhss))
      = do  { lhs <- checkPattern msg lhs
            ; return ([],PatBind noExt lhs grhss
                        ([],[])) }

    checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
    checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
      | isUnqual v
      , not (isDataOcc (rdrNameOcc v))
      = return lrdr

    checkValSigLhs lhs@(L l _)
      = parseErrorSDoc l ((text "Invalid type signature:" <+>
                           ppr lhs <+> text ":: ...")
                          $$ text hint)
      where
        hint | foreign_RDR `looks_like` lhs
             = "Perhaps you meant to use ForeignFunctionInterface?"
             | default_RDR `looks_like` lhs
             = "Perhaps you meant to use DefaultSignatures?"
             | pattern_RDR `looks_like` lhs
             = "Perhaps you meant to use PatternSynonyms?"
             | otherwise
             = "Should be of form <variable> :: <type>"

        -- A common error is to forget the ForeignFunctionInterface flag
        -- so check for that, and suggest.  cf Trac #3805
        -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
        looks_like s (L _ (HsVar _ (L _ v))) = v == s
        looks_like s (L _ (HsApp _ lhs _))   = looks_like s lhs
        looks_like _ _                       = False

        foreign_RDR = mkUnqual varName (fsLit "foreign")
        default_RDR = mkUnqual varName (fsLit "default")
        pattern_RDR = mkUnqual varName (fsLit "pattern")

    checkDoAndIfThenElse :: LHsExpr GhcPs
                         -> Bool
                         -> LHsExpr GhcPs
                         -> Bool
                         -> LHsExpr GhcPs
                         -> P ()
    checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
     | semiThen || semiElse
        = do pState <- getPState
             unless (extopt LangExt.DoAndIfThenElse (options pState)) $ do
                 parseErrorSDoc (combineLocs guardExpr elseExpr)
                                (text "Unexpected semi-colons in conditional:"
                              $$ nest 4 expr
                              $$ text "Perhaps you meant to use DoAndIfThenElse?")
     | otherwise            = return ()
        where pprOptSemi True  = semi
              pprOptSemi False = empty
              expr = text "if"   <+> ppr guardExpr <> pprOptSemi semiThen <+>
                     text "then" <+> ppr thenExpr  <> pprOptSemi semiElse <+>
                     text "else" <+> ppr elseExpr

            -- The parser left-associates, so there should
            -- not be any OpApps inside the e's
    splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
    -- Splits (f ! g a b) into (f, [(! g), a, b])
    splitBang (L _ (OpApp _ l_arg bang@(L _ (HsVar _ (L _ op))) r_arg))
      | op == bang_RDR = Just (l_arg, L l' (SectionR noExt bang arg1) : argns)
      where
        l' = combineLocs bang arg1
        (arg1,argns) = split_bang r_arg []
        split_bang (L _ (HsApp _ f e)) es = split_bang f (e:es)
        split_bang e                   es = (e,es)
    splitBang _ = Nothing

    isFunLhs :: LHsExpr GhcPs
          -> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs],[AddAnn]))
    -- A variable binding is parsed as a FunBind.
    -- Just (fun, is_infix, arg_pats) if e is a function LHS
    --
    -- The whole LHS is parsed as a single expression.
    -- Any infix operators on the LHS will parse left-associatively
    -- E.g.         f !x y !z
    --      will parse (rather strangely) as
    --              (f ! x y) ! z
    --      It's up to isFunLhs to sort out the mess
    --
    -- a .!. !b

    isFunLhs e = go e [] []
     where
       go (L loc (HsVar _ (L _ f))) es ann
            | not (isRdrDataCon f)        = return (Just (L loc f, Prefix, es, ann))
       go (L _ (HsApp _ f e)) es       ann = go f (e:es) ann
       go (L l (HsPar _ e))   es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)

            -- Things of the form `!x` are also FunBinds
            -- See Note [FunBind vs PatBind]
       go (L _ (SectionR _ (L _ (HsVar _ (L _ bang))) (L l (HsVar _ (L _ var)))))
                                                                             [] ann
            | bang == bang_RDR
            , not (isRdrDataCon var)     = return (Just (L l var, Prefix, [], ann))

            -- For infix function defns, there should be only one infix *function*
            -- (though there may be infix *datacons* involved too).  So we don't
            -- need fixity info to figure out which function is being defined.
            --      a `K1` b `op` c `K2` d
            -- must parse as
            --      (a `K1` b) `op` (c `K2` d)
            -- The renamer checks later that the precedences would yield such a parse.
            --
            -- There is a complication to deal with bang patterns.
            --
            -- ToDo: what about this?
            --              x + 1 `op` y = ...

       go e@(L loc (OpApp _ l (L loc' (HsVar _ (L _ op))) r)) es ann
            | Just (e',es') <- splitBang e
            = do { bang_on <- extension bangPatEnabled
                 ; if bang_on then go e' (es' ++ es) ann
                   else return (Just (L loc' op, Infix, (l:r:es), ann)) }
                    -- No bangs; behave just like the next case
            | not (isRdrDataCon op)         -- We have found the function!
            = return (Just (L loc' op, Infix, (l:r:es), ann))
            | otherwise                     -- Infix data con; keep going
            = do { mb_l <- go l es ann
                 ; case mb_l of
                     Just (op', Infix, j : k : es', ann')
                       -> return (Just (op', Infix, j : op_app : es', ann'))
                       where
                         op_app = L loc (OpApp noExt k
                                           (L loc' (HsVar noExt (L loc' op))) r)
                     _ -> return Nothing }
       go _ _ _ = return Nothing

    -- | Transform a list of 'atype' with 'strict_mark' into
    -- HsOpTy's of 'eqTyCon_RDR':
    --
    --   [~a, ~b, c, ~d] ==> (~a) ~ ((b c) ~ d)
    --
    -- See Note [Parsing ~]
    splitTilde :: [LHsType GhcPs] -> P (LHsType GhcPs)
    splitTilde [] = panic "splitTilde"
    splitTilde (x:xs) = go x xs
      where
        -- We accumulate applications in the LHS until we encounter a laziness
        -- annotation. For example, if we have [Foo, x, y, ~Bar, z], the 'lhs'
        -- accumulator will become '(Foo x) y'. Then we strip the laziness
        -- annotation off 'Bar' and process the tail [Bar, z] recursively.
        --
        -- This leaves us with 'lhs = (Foo x) y' and 'rhs = Bar z'.
        -- In case the tail contained more laziness annotations, they would be
        -- processed similarly. This makes '~' right-associative.
        go lhs [] = return lhs
        go lhs (x:xs)
          | L loc (HsBangTy _ (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t) <- x
          = do { rhs <- splitTilde (t:xs)
               ; let r = mkLHsOpTy lhs (tildeOp loc) rhs
               ; moveAnnotations loc (getLoc r)
               ; return r }
          | otherwise
          = go (mkHsAppTy lhs x) xs

        tildeOp loc = L (srcSpanFirstCharacter loc) eqTyCon_RDR

    -- | Either an operator or an operand.
    data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)

    -- | Merge a /reversed/ and /non-empty/ soup of operators and operands
    --   into a type.
    --
    -- User input: @F x y + G a b * X@
    -- Input to 'mergeOps': [X, *, b, a, G, +, y, x, F]
    -- Output corresponds to what the user wrote assuming all operators are of the
    -- same fixity and right-associative.
    --
    -- It's a bit silly that we're doing it at all, as the renamer will have to
    -- rearrange this, and it'd be easier to keep things separate.
    mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
    mergeOps = go [] id
      where
        -- clause (a):
        -- when we encounter an operator, we must have accumulated
        -- something for its rhs, and there must be something left
        -- to build its lhs.
        go acc ops_acc (L l (TyElOpr op):xs) =
          if null acc || null xs
            then failOpFewArgs (L l op)
            else do { a <- splitTilde acc
                    ; go [] (\c -> mkLHsOpTy c (L l op) (ops_acc a)) xs }

        -- clause (b):
        -- whenever an operand is encountered, it is added to the accumulator
        go acc ops_acc (L l (TyElOpd a):xs) = go (L l a:acc) ops_acc xs

        -- clause (c):
        -- at this point we know that 'acc' is non-empty because
        -- there are three options when 'acc' can be empty:
        -- 1. 'mergeOps' was called with an empty list, and this
        --    should never happen
        -- 2. 'mergeOps' was called with a list where the head is an
        --    operator, this is handled by clause (a)
        -- 3. 'mergeOps' was called with a list where the head is an
        --    operand, this is handled by clause (b)
        go acc ops_acc [] =
          do { a <- splitTilde acc
             ; return (ops_acc a) }

    ---------------------------------------------------------------------------
    -- Check for monad comprehensions
    --
    -- If the flag MonadComprehensions is set, return a `MonadComp' context,
    -- otherwise use the usual `ListComp' context

    checkMonadComp :: P (HsStmtContext Name)
    checkMonadComp = do
        pState <- getPState
        return $ if extopt LangExt.MonadComprehensions (options pState)
                    then MonadComp
                    else ListComp

    -- -------------------------------------------------------------------------
    -- Checking arrow syntax.

    -- We parse arrow syntax as expressions and check for valid syntax below,
    -- converting the expression into a pattern at the same time.

    checkCommand :: LHsExpr GhcPs -> P (LHsCmd GhcPs)
    checkCommand lc = locMap checkCmd lc

    locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
    locMap f (L l a) = f l a >>= (\b -> return $ L l b)

    checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs)
    checkCmd _ (HsArrApp _ e1 e2 haat b) =
        return $ HsCmdArrApp noExt e1 e2 haat b
    checkCmd _ (HsArrForm _ e mf args) =
        return $ HsCmdArrForm noExt e Prefix mf args
    checkCmd _ (HsApp _ e1 e2) =
        checkCommand e1 >>= (\c -> return $ HsCmdApp noExt c e2)
    checkCmd _ (HsLam _ mg) =
        checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam noExt mg')
    checkCmd _ (HsPar _ e) =
        checkCommand e >>= (\c -> return $ HsCmdPar noExt c)
    checkCmd _ (HsCase _ e mg) =
        checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase noExt e mg')
    checkCmd _ (HsIf _ cf ep et ee) = do
        pt <- checkCommand et
        pe <- checkCommand ee
        return $ HsCmdIf noExt cf ep pt pe
    checkCmd _ (HsLet _ lb e) =
        checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c)
    checkCmd _ (HsDo _ DoExpr (L l stmts)) =
        mapM checkCmdLStmt stmts >>=
        (\ss -> return $ HsCmdDo noExt (L l ss) )

    checkCmd _ (OpApp _ eLeft op eRight) = do
        -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
        c1 <- checkCommand eLeft
        c2 <- checkCommand eRight
        let arg1 = L (getLoc c1) $ HsCmdTop noExt c1
            arg2 = L (getLoc c2) $ HsCmdTop noExt c2
        return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2]

    checkCmd l e = cmdFail l e

    checkCmdLStmt :: ExprLStmt GhcPs -> P (CmdLStmt GhcPs)
    checkCmdLStmt = locMap checkCmdStmt

    checkCmdStmt :: SrcSpan -> ExprStmt GhcPs -> P (CmdStmt GhcPs)
    checkCmdStmt _ (LastStmt x e s r) =
        checkCommand e >>= (\c -> return $ LastStmt x c s r)
    checkCmdStmt _ (BindStmt x pat e b f) =
        checkCommand e >>= (\c -> return $ BindStmt x pat c b f)
    checkCmdStmt _ (BodyStmt x e t g) =
        checkCommand e >>= (\c -> return $ BodyStmt x c t g)
    checkCmdStmt _ (LetStmt x bnds) = return $ LetStmt x bnds
    checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do
        ss <- mapM checkCmdLStmt stmts
        return $ stmt { recS_ext = noExt, recS_stmts = ss }
    checkCmdStmt _ (XStmtLR _) = panic "checkCmdStmt"
    checkCmdStmt l stmt = cmdStmtFail l stmt

    checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
                       -> P (MatchGroup GhcPs (LHsCmd GhcPs))
    checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do
        ms' <- mapM (locMap $ const convert) ms
        return $ mg { mg_ext = noExt, mg_alts = L l ms' }
        where convert match@(Match { m_grhss = grhss }) = do
                grhss' <- checkCmdGRHSs grhss
                return $ match { m_ext = noExt, m_grhss = grhss'}
              convert (XMatch _) = panic "checkCmdMatchGroup.XMatch"
    checkCmdMatchGroup (XMatchGroup {}) = panic "checkCmdMatchGroup"

    checkCmdGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs))
    checkCmdGRHSs (GRHSs x grhss binds) = do
        grhss' <- mapM checkCmdGRHS grhss
        return $ GRHSs x grhss' binds
    checkCmdGRHSs (XGRHSs _) = panic "checkCmdGRHSs"

    checkCmdGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs))
    checkCmdGRHS = locMap $ const convert
      where
        convert (GRHS x stmts e) = do
            c <- checkCommand e
    --        cmdStmts <- mapM checkCmdLStmt stmts
            return $ GRHS x {- cmdStmts -} stmts c
        convert (XGRHS _) = panic "checkCmdGRHS"

    cmdFail :: SrcSpan -> HsExpr GhcPs -> P a
    cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e)
    cmdStmtFail :: SrcSpan -> Stmt GhcPs (LHsExpr GhcPs) -> P a
    cmdStmtFail loc e = parseErrorSDoc loc
                        (text "Parse error in command statement:" <+> ppr e)

    ---------------------------------------------------------------------------
    -- Miscellaneous utilities

    checkPrecP :: Located (SourceText,Int) -> P (Located (SourceText,Int))
    checkPrecP (L l (src,i))
     | 0 <= i && i <= maxPrecedence = return (L l (src,i))
     | otherwise
        = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))

    mkRecConstrOrUpdate
            :: LHsExpr GhcPs
            -> SrcSpan
            -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)
            -> P (HsExpr GhcPs)

    mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
      | isRdrDataCon c
      = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
    mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
      | dd        = parseErrorSDoc l (text "You cannot use `..' in a record update")
      | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))

    mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
    mkRdrRecordUpd exp flds
      = RecordUpd { rupd_ext  = noExt
                  , rupd_expr = exp
                  , rupd_flds = flds }

    mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
    mkRdrRecordCon con flds
      = RecordCon { rcon_ext = noExt, rcon_con_name = con, rcon_flds = flds }

    mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
    mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
    mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }

    mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
    mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun)
      = HsRecField (L loc (Unambiguous noExt rdr)) arg pun
    mk_rec_upd_field (HsRecField (L _ (XFieldOcc _)) _ _)
      = panic "mk_rec_upd_field"

    mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
                   -> InlinePragma
    -- The (Maybe Activation) is because the user can omit
    -- the activation spec (and usually does)
    mkInlinePragma src (inl, match_info) mb_act
      = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes
                     , inl_inline = inl
                     , inl_sat    = Nothing
                     , inl_act    = act
                     , inl_rule   = match_info }
      where
        act = case mb_act of
                Just act -> act
                Nothing  -> -- No phase specified
                            case inl of
                              NoInline -> NeverActive
                              _other   -> AlwaysActive

    -----------------------------------------------------------------------------
    -- utilities for foreign declarations

    -- construct a foreign import declaration
    --
    mkImport :: Located CCallConv
             -> Located Safety
             -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
             -> P (HsDecl GhcPs)
    mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
        case cconv of
          L _ CCallConv          -> mkCImport
          L _ CApiConv           -> mkCImport
          L _ StdCallConv        -> mkCImport
          L _ PrimCallConv       -> mkOtherImport
          L _ JavaScriptCallConv -> mkOtherImport
      where
        -- Parse a C-like entity string of the following form:
        --   "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"
        -- If 'cid' is missing, the function name 'v' is used instead as symbol
        -- name (cf section 8.5.1 in Haskell 2010 report).
        mkCImport = do
          let e = unpackFS entity
          case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
            Nothing         -> parseErrorSDoc loc (text "Malformed entity string")
            Just importSpec -> returnSpec importSpec

        -- currently, all the other import conventions only support a symbol name in
        -- the entity string. If it is missing, we use the function name instead.
        mkOtherImport = returnSpec importSpec
          where
            entity'    = if nullFS entity
                            then mkExtName (unLoc v)
                            else entity
            funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
            importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)

        returnSpec spec = return $ ForD noExt $ ForeignImport
              { fd_i_ext  = noExt
              , fd_name   = v
              , fd_sig_ty = ty
              , fd_fi     = spec
              }

    -- the string "foo" is ambiguous: either a header or a C identifier.  The
    -- C identifier case comes first in the alternatives below, so we pick
    -- that one.
    parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
                 -> Located SourceText
                 -> Maybe ForeignImport
    parseCImport cconv safety nm str sourceText =
     listToMaybe $ map fst $ filter (null.snd) $
         readP_to_S parse str
     where
       parse = do
           skipSpaces
           r <- choice [
              string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),
              string "wrapper" >> return (mk Nothing CWrapper),
              do optional (token "static" >> skipSpaces)
                 ((mk Nothing <$> cimp nm) +++
                  (do h <- munch1 hdr_char
                      skipSpaces
                      mk (Just (Header (SourceText h) (mkFastString h)))
                          <$> cimp nm))
             ]
           skipSpaces
           return r

       token str = do _ <- string str
                      toks <- look
                      case toks of
                          c : _
                           | id_char c -> pfail
                          _            -> return ()

       mk h n = CImport cconv safety h n sourceText

       hdr_char c = not (isSpace c) -- header files are filenames, which can contain
                                    -- pretty much any char (depending on the platform),
                                    -- so just accept any non-space character
       id_first_char c = isAlpha    c || c == '_'
       id_char       c = isAlphaNum c || c == '_'

       cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
                 +++ (do isFun <- case cconv of
                                  L _ CApiConv ->
                                      option True
                                             (do token "value"
                                                 skipSpaces
                                                 return False)
                                  _ -> return True
                         cid' <- cid
                         return (CFunction (StaticTarget NoSourceText cid'
                                            Nothing isFun)))
              where
                cid = return nm +++
                      (do c  <- satisfy id_first_char
                          cs <-  many (satisfy id_char)
                          return (mkFastString (c:cs)))

    -- construct a foreign export declaration
    --
    mkExport :: Located CCallConv
             -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
             -> P (HsDecl GhcPs)
    mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
     = return $ ForD noExt $
       ForeignExport { fd_e_ext = noExt, fd_name = v, fd_sig_ty = ty
                     , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
                                       (L le esrc) }
      where
        entity' | nullFS entity = mkExtName (unLoc v)
                | otherwise     = entity

    -- Supplying the ext_name in a foreign decl is optional; if it
    -- isn't there, the Haskell name is assumed. Note that no transformation
    -- of the Haskell name is then performed, so if you foreign export (++),
    -- it's external name will be "++". Too bad; it's important because we don't
    -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
    --
    mkExtName :: RdrName -> CLabelString
    mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))

    --------------------------------------------------------------------------------
    -- Help with module system imports/exports

    data ImpExpSubSpec = ImpExpAbs
                       | ImpExpAll
                       | ImpExpList [Located ImpExpQcSpec]
                       | ImpExpAllWith [Located ImpExpQcSpec]

    data ImpExpQcSpec = ImpExpQcName (Located RdrName)
                      | ImpExpQcType (Located RdrName)
                      | ImpExpQcWildcard

    mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
    mkModuleImpExp (L l specname) subs =
      case subs of
        ImpExpAbs
          | isVarNameSpace (rdrNameSpace name)
                             -> return $ IEVar noExt (L l (ieNameFromSpec specname))
          | otherwise        -> IEThingAbs noExt . L l <$> nameT
        ImpExpAll            -> IEThingAll noExt . L l <$> nameT
        ImpExpList xs        ->
          (\newName -> IEThingWith noExt (L l newName) NoIEWildcard (wrapped xs) [])
            <$> nameT
        ImpExpAllWith xs                       ->
          do allowed <- extension patternSynonymsEnabled
             if allowed
              then
                let withs = map unLoc xs
                    pos   = maybe NoIEWildcard IEWildcard
                              (findIndex isImpExpQcWildcard withs)
                    ies   = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs
                in (\newName
                            -> IEThingWith noExt (L l newName) pos ies []) <$> nameT
              else parseErrorSDoc l
                (text "Illegal export form (use PatternSynonyms to enable)")
      where
        name = ieNameVal specname
        nameT =
          if isVarNameSpace (rdrNameSpace name)
            then parseErrorSDoc l
                  (text "Expecting a type constructor but found a variable,"
                   <+> quotes (ppr name) <> text "."
                  $$ if isSymOcc $ rdrNameOcc name
                       then text "If" <+> quotes (ppr name) <+> text "is a type constructor"
                        <+> text "then enable ExplicitNamespaces and use the 'type' keyword."
                       else empty)
            else return $ ieNameFromSpec specname

        ieNameVal (ImpExpQcName ln)  = unLoc ln
        ieNameVal (ImpExpQcType ln)  = unLoc ln
        ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard"

        ieNameFromSpec (ImpExpQcName ln)  = IEName ln
        ieNameFromSpec (ImpExpQcType ln)  = IEType ln
        ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard"

        wrapped = map (\(L l x) -> L l (ieNameFromSpec x))

    mkTypeImpExp :: Located RdrName   -- TcCls or Var name space
                 -> P (Located RdrName)
    mkTypeImpExp name =
      do allowed <- extension explicitNamespacesEnabled
         if allowed
           then return (fmap (`setRdrNameSpace` tcClsName) name)
           else parseErrorSDoc (getLoc name)
                  (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")

    checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
    checkImportSpec ie@(L _ specs) =
        case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
          [] -> return ie
          (l:_) -> importSpecError l
      where
        importSpecError l =
          parseErrorSDoc l
            (text "Illegal import form, this syntax can only be used to bundle"
            $+$ text "pattern synonyms with types in module exports.")

    -- In the correct order
    mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)
    mkImpExpSubSpec [] = return ([], ImpExpList [])
    mkImpExpSubSpec [L _ ImpExpQcWildcard] =
      return ([], ImpExpAll)
    mkImpExpSubSpec xs =
      if (any (isImpExpQcWildcard . unLoc) xs)
        then return $ ([], ImpExpAllWith xs)
        else return $ ([], ImpExpList xs)

    isImpExpQcWildcard :: ImpExpQcSpec -> Bool
    isImpExpQcWildcard ImpExpQcWildcard = True
    isImpExpQcWildcard _                = False

    -----------------------------------------------------------------------------
    -- Warnings and failures

    warnStarIsType :: SrcSpan -> P ()
    warnStarIsType span = addWarning Opt_WarnStarIsType span msg
      where
        msg =  text "Using" <+> quotes (text "*")
               <+> text "(or its Unicode variant) to mean"
               <+> quotes (text "Data.Kind.Type")
            $$ text "relies on the StarIsType extension."
            $$ text "Suggested fix: use" <+> quotes (text "Type")
               <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."

    warnStarBndr :: SrcSpan -> P ()
    warnStarBndr span = addWarning Opt_WarnStarBinder span msg
      where
        msg =  text "Found binding occurrence of" <+> quotes (text "*")
               <+> text "yet StarIsType is enabled."
            $$ text "NB. To use (or export) this operator in"
               <+> text "modules with StarIsType,"
            $$ text "    including the definition module, you must qualify it."

    failOpFewArgs :: Located RdrName -> P a
    failOpFewArgs (L loc op) =
      do { star_is_type <- extension starIsTypeEnabled
         ; let msg = too_few $$ starInfo star_is_type op
         ; parseErrorSDoc loc msg }
      where
        too_few = text "Operator applied to too few arguments:" <+> ppr op

    -----------------------------------------------------------------------------
    -- Misc utils

    parseErrorSDoc :: SrcSpan -> SDoc -> P a
    parseErrorSDoc span s = failSpanMsgP span s

    -- | Hint about bang patterns, assuming @BangPatterns@ is off.
    hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
    hintBangPat span e = do
        bang_on <- extension bangPatEnabled
        unless bang_on $
          parseErrorSDoc span
            (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)

    data SumOrTuple
      = Sum ConTag Arity (LHsExpr GhcPs)
      | Tuple [LHsTupArg GhcPs]

    mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs)

    -- Tuple
    mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity)

    -- Sum
    mkSumOrTuple Unboxed _ (Sum alt arity e) =
        return (ExplicitSum noExt alt arity e)
    mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =
        parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e))
      where
        ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc
        ppr_boxed_sum alt arity e =
          text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")"

        ppr_bars n = hsep (replicate n (Outputable.char '|'))

    mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
    mkLHsOpTy x op y =
      let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
      in L loc (mkHsOpTy x op y)