never executed always true always false
    1 {-# LANGUAGE BangPatterns #-}
    2 {-# LANGUAGE ConstrainedClassMethods #-}
    3 {-# LANGUAGE DeriveFunctor #-}
    4 {-# LANGUAGE FlexibleContexts #-}
    5 {-# LANGUAGE FunctionalDependencies #-}
    6 {-# LANGUAGE LambdaCase #-}
    7 {-# LANGUAGE ScopedTypeVariables #-}
    8 {-# LANGUAGE TypeFamilies #-}
    9 {-# LANGUAGE ViewPatterns #-}
   10 
   11 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
   12 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
   13 
   14 {-
   15 (c) The University of Glasgow 2006
   16 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   17 
   18 
   19 This module converts Template Haskell syntax into Hs syntax
   20 -}
   21 
   22 module GHC.ThToHs
   23    ( convertToHsExpr
   24    , convertToPat
   25    , convertToHsDecls
   26    , convertToHsType
   27    , thRdrNameGuesses
   28    )
   29 where
   30 
   31 import GHC.Prelude
   32 
   33 import GHC.Hs as Hs
   34 import GHC.Builtin.Names
   35 import GHC.Types.Name.Reader
   36 import qualified GHC.Types.Name as Name
   37 import GHC.Unit.Module
   38 import GHC.Parser.PostProcess
   39 import GHC.Types.Name.Occurrence as OccName
   40 import GHC.Types.SrcLoc
   41 import GHC.Core.Type as Hs
   42 import qualified GHC.Core.Coercion as Coercion ( Role(..) )
   43 import GHC.Builtin.Types
   44 import GHC.Types.Basic as Hs
   45 import GHC.Types.Fixity as Hs
   46 import GHC.Types.ForeignCall
   47 import GHC.Types.Unique
   48 import GHC.Types.SourceText
   49 import GHC.Utils.Error
   50 import GHC.Data.Bag
   51 import GHC.Utils.Lexeme
   52 import GHC.Utils.Misc
   53 import GHC.Data.FastString
   54 import GHC.Utils.Outputable as Outputable
   55 import GHC.Utils.Panic
   56 
   57 import qualified Data.ByteString as BS
   58 import Control.Monad( unless, ap )
   59 
   60 import Data.Maybe( catMaybes, isNothing )
   61 import Language.Haskell.TH as TH hiding (sigP)
   62 import Language.Haskell.TH.Syntax as TH
   63 import Foreign.ForeignPtr
   64 import Foreign.Ptr
   65 import System.IO.Unsafe
   66 
   67 -------------------------------------------------------------------
   68 --              The external interface
   69 
   70 convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either SDoc [LHsDecl GhcPs]
   71 convertToHsDecls origin loc ds = initCvt origin loc (fmap catMaybes (mapM cvt_dec ds))
   72   where
   73     cvt_dec d = wrapMsg "declaration" d (cvtDec d)
   74 
   75 convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either SDoc (LHsExpr GhcPs)
   76 convertToHsExpr origin loc e
   77   = initCvt origin loc $ wrapMsg "expression" e $ cvtl e
   78 
   79 convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either SDoc (LPat GhcPs)
   80 convertToPat origin loc p
   81   = initCvt origin loc $ wrapMsg "pattern" p $ cvtPat p
   82 
   83 convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either SDoc (LHsType GhcPs)
   84 convertToHsType origin loc t
   85   = initCvt origin loc $ wrapMsg "type" t $ cvtType t
   86 
   87 -------------------------------------------------------------------
   88 newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either SDoc (SrcSpan, a) }
   89     deriving (Functor)
   90         -- Push down the Origin (that is configurable by
   91         -- -fenable-th-splice-warnings) and source location;
   92         -- Can fail, with a single error message
   93 
   94 -- NB: If the conversion succeeds with (Right x), there should
   95 --     be no exception values hiding in x
   96 -- Reason: so a (head []) in TH code doesn't subsequently
   97 --         make GHC crash when it tries to walk the generated tree
   98 
   99 -- Use the loc everywhere, for lack of anything better
  100 -- In particular, we want it on binding locations, so that variables bound in
  101 -- the spliced-in declarations get a location that at least relates to the splice point
  102 
  103 instance Applicative CvtM where
  104     pure x = CvtM $ \_ loc -> Right (loc,x)
  105     (<*>) = ap
  106 
  107 instance Monad CvtM where
  108   (CvtM m) >>= k = CvtM $ \origin loc -> case m origin loc of
  109     Left err -> Left err
  110     Right (loc',v) -> unCvtM (k v) origin loc'
  111 
  112 initCvt :: Origin -> SrcSpan -> CvtM a -> Either SDoc a
  113 initCvt origin loc (CvtM m) = fmap snd (m origin loc)
  114 
  115 force :: a -> CvtM ()
  116 force a = a `seq` return ()
  117 
  118 failWith :: SDoc -> CvtM a
  119 failWith m = CvtM (\_ _ -> Left m)
  120 
  121 getOrigin :: CvtM Origin
  122 getOrigin = CvtM (\origin loc -> Right (loc,origin))
  123 
  124 getL :: CvtM SrcSpan
  125 getL = CvtM (\_ loc -> Right (loc,loc))
  126 
  127 setL :: SrcSpan -> CvtM ()
  128 setL loc = CvtM (\_ _ -> Right (loc, ()))
  129 
  130 returnLA :: e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
  131 returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x))
  132 
  133 returnJustLA :: a -> CvtM (Maybe (LocatedA a))
  134 returnJustLA = fmap Just . returnLA
  135 
  136 wrapParLA :: (LocatedA a -> a) -> a -> CvtM a
  137 wrapParLA add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpan loc) x)))
  138 
  139 wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
  140 -- E.g  wrapMsg "declaration" dec thing
  141 wrapMsg what item (CvtM m)
  142   = CvtM $ \origin loc -> case m origin loc of
  143       Left err -> Left (err $$ msg)
  144       Right v  -> Right v
  145   where
  146         -- Show the item in pretty syntax normally,
  147         -- but with all its constructors if you say -dppr-debug
  148     msg = hang (text "When splicing a TH" <+> text what <> colon)
  149                  2 (getPprDebug $ \case
  150                      True  -> text (show item)
  151                      False -> text (pprint item))
  152 
  153 wrapL :: CvtM a -> CvtM (Located a)
  154 wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of
  155   Left err -> Left err
  156   Right (loc', v) -> Right (loc', L loc v)
  157 
  158 wrapLN :: CvtM a -> CvtM (LocatedN a)
  159 wrapLN (CvtM m) = CvtM $ \origin loc -> case m origin loc of
  160   Left err -> Left err
  161   Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v)
  162 
  163 wrapLA :: CvtM a -> CvtM (LocatedA a)
  164 wrapLA (CvtM m) = CvtM $ \origin loc -> case m origin loc of
  165   Left err -> Left err
  166   Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v)
  167 
  168 -------------------------------------------------------------------
  169 cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
  170 cvtDecs = fmap catMaybes . mapM cvtDec
  171 
  172 cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))
  173 cvtDec (TH.ValD pat body ds)
  174   | TH.VarP s <- pat
  175   = do  { s' <- vNameN s
  176         ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
  177         ; th_origin <- getOrigin
  178         ; returnJustLA $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] }
  179 
  180   | otherwise
  181   = do  { pat' <- cvtPat pat
  182         ; body' <- cvtGuard body
  183         ; ds' <- cvtLocalDecs (text "a where clause") ds
  184         ; returnJustLA $ Hs.ValD noExtField $
  185           PatBind { pat_lhs = pat'
  186                   , pat_rhs = GRHSs emptyComments body' ds'
  187                   , pat_ext = noAnn
  188                   , pat_ticks = ([],[]) } }
  189 
  190 cvtDec (TH.FunD nm cls)
  191   | null cls
  192   = failWith (text "Function binding for"
  193                  <+> quotes (text (TH.pprint nm))
  194                  <+> text "has no equations")
  195   | otherwise
  196   = do  { nm' <- vNameN nm
  197         ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
  198         ; th_origin <- getOrigin
  199         ; returnJustLA $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' }
  200 
  201 cvtDec (TH.SigD nm typ)
  202   = do  { nm' <- vNameN nm
  203         ; ty' <- cvtSigType typ
  204         ; returnJustLA $ Hs.SigD noExtField
  205                                     (TypeSig noAnn [nm'] (mkHsWildCardBndrs ty')) }
  206 
  207 cvtDec (TH.KiSigD nm ki)
  208   = do  { nm' <- tconNameN nm
  209         ; ki' <- cvtSigKind ki
  210         ; let sig' = StandaloneKindSig noAnn nm' ki'
  211         ; returnJustLA $ Hs.KindSigD noExtField sig' }
  212 
  213 cvtDec (TH.InfixD fx nm)
  214   -- Fixity signatures are allowed for variables, constructors, and types
  215   -- the renamer automatically looks for types during renaming, even when
  216   -- the RdrName says it's a variable or a constructor. So, just assume
  217   -- it's a variable or constructor and proceed.
  218   = do { nm' <- vcNameN nm
  219        ; returnJustLA (Hs.SigD noExtField (FixSig noAnn
  220                                       (FixitySig noExtField [nm'] (cvtFixity fx)))) }
  221 
  222 cvtDec (TH.DefaultD tys)
  223   = do  { tys' <- traverse cvtType tys
  224         ; returnJustLA (Hs.DefD noExtField $ DefaultDecl noAnn tys') }
  225 
  226 cvtDec (PragmaD prag)
  227   = cvtPragmaD prag
  228 
  229 cvtDec (TySynD tc tvs rhs)
  230   = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
  231         ; rhs' <- cvtType rhs
  232         ; returnJustLA $ TyClD noExtField $
  233           SynDecl { tcdSExt = noAnn, tcdLName = tc', tcdTyVars = tvs'
  234                   , tcdFixity = Prefix
  235                   , tcdRhs = rhs' } }
  236 
  237 cvtDec (DataD ctxt tc tvs ksig constrs derivs)
  238   = do  { let isGadtCon (GadtC    _ _ _) = True
  239               isGadtCon (RecGadtC _ _ _) = True
  240               isGadtCon (ForallC  _ _ c) = isGadtCon c
  241               isGadtCon _                = False
  242               isGadtDecl  = all isGadtCon constrs
  243               isH98Decl   = all (not . isGadtCon) constrs
  244         ; unless (isGadtDecl || isH98Decl)
  245                  (failWith (text "Cannot mix GADT constructors with Haskell 98"
  246                         <+> text "constructors"))
  247         ; unless (isNothing ksig || isGadtDecl)
  248                  (failWith (text "Kind signatures are only allowed on GADTs"))
  249         ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
  250         ; ksig' <- cvtKind `traverse` ksig
  251         ; cons' <- mapM cvtConstr constrs
  252         ; derivs' <- cvtDerivs derivs
  253         ; let defn = HsDataDefn { dd_ext = noExtField
  254                                 , dd_ND = DataType, dd_cType = Nothing
  255                                 , dd_ctxt = mkHsContextMaybe ctxt'
  256                                 , dd_kindSig = ksig'
  257                                 , dd_cons = cons', dd_derivs = derivs' }
  258         ; returnJustLA $ TyClD noExtField $
  259           DataDecl { tcdDExt = noAnn
  260                    , tcdLName = tc', tcdTyVars = tvs'
  261                    , tcdFixity = Prefix
  262                    , tcdDataDefn = defn } }
  263 
  264 cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
  265   = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
  266         ; ksig' <- cvtKind `traverse` ksig
  267         ; con' <- cvtConstr constr
  268         ; derivs' <- cvtDerivs derivs
  269         ; let defn = HsDataDefn { dd_ext = noExtField
  270                                 , dd_ND = NewType, dd_cType = Nothing
  271                                 , dd_ctxt = mkHsContextMaybe ctxt'
  272                                 , dd_kindSig = ksig'
  273                                 , dd_cons = [con']
  274                                 , dd_derivs = derivs' }
  275         ; returnJustLA $ TyClD noExtField $
  276           DataDecl { tcdDExt = noAnn
  277                    , tcdLName = tc', tcdTyVars = tvs'
  278                    , tcdFixity = Prefix
  279                    , tcdDataDefn = defn } }
  280 
  281 cvtDec (ClassD ctxt cl tvs fds decs)
  282   = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
  283         ; fds'  <- mapM cvt_fundep fds
  284         ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs (text "a class declaration") decs
  285         ; unless (null adts')
  286             (failWith $ (text "Default data instance declarations"
  287                      <+> text "are not allowed:")
  288                    $$ (Outputable.ppr adts'))
  289         ; returnJustLA $ TyClD noExtField $
  290           ClassDecl { tcdCExt = (noAnn, NoAnnSortKey, NoLayoutInfo)
  291                     , tcdCtxt = mkHsContextMaybe cxt', tcdLName = tc', tcdTyVars = tvs'
  292                     , tcdFixity = Prefix
  293                     , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
  294                     , tcdMeths = binds'
  295                     , tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] }
  296                               -- no docs in TH ^^
  297         }
  298 
  299 cvtDec (InstanceD o ctxt ty decs)
  300   = do  { let doc = text "an instance declaration"
  301         ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
  302         ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
  303         ; ctxt' <- cvtContext funPrec ctxt
  304         ; (L loc ty') <- cvtType ty
  305         ; let inst_ty' = L loc $ mkHsImplicitSigType $
  306                          mkHsQualTy ctxt loc ctxt' $ L loc ty'
  307         ; returnJustLA $ InstD noExtField $ ClsInstD noExtField $
  308           ClsInstDecl { cid_ext = (noAnn, NoAnnSortKey), cid_poly_ty = inst_ty'
  309                       , cid_binds = binds'
  310                       , cid_sigs = Hs.mkClassOpSigs sigs'
  311                       , cid_tyfam_insts = ats', cid_datafam_insts = adts'
  312                       , cid_overlap_mode
  313                                    = fmap (L (l2l loc) . overlap) o } }
  314   where
  315   overlap pragma =
  316     case pragma of
  317       TH.Overlaps      -> Hs.Overlaps     (SourceText "OVERLAPS")
  318       TH.Overlappable  -> Hs.Overlappable (SourceText "OVERLAPPABLE")
  319       TH.Overlapping   -> Hs.Overlapping  (SourceText "OVERLAPPING")
  320       TH.Incoherent    -> Hs.Incoherent   (SourceText "INCOHERENT")
  321 
  322 
  323 
  324 
  325 cvtDec (ForeignD ford)
  326   = do { ford' <- cvtForD ford
  327        ; returnJustLA $ ForD noExtField ford' }
  328 
  329 cvtDec (DataFamilyD tc tvs kind)
  330   = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
  331        ; result <- cvtMaybeKindToFamilyResultSig kind
  332        ; returnJustLA $ TyClD noExtField $ FamDecl noExtField $
  333          FamilyDecl noAnn DataFamily TopLevel tc' tvs' Prefix result Nothing }
  334 
  335 cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
  336   = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
  337        ; ksig' <- cvtKind `traverse` ksig
  338        ; cons' <- mapM cvtConstr constrs
  339        ; derivs' <- cvtDerivs derivs
  340        ; let defn = HsDataDefn { dd_ext = noExtField
  341                                , dd_ND = DataType, dd_cType = Nothing
  342                                , dd_ctxt = mkHsContextMaybe ctxt'
  343                                , dd_kindSig = ksig'
  344                                , dd_cons = cons', dd_derivs = derivs' }
  345 
  346        ; returnJustLA $ InstD noExtField $ DataFamInstD
  347            { dfid_ext = noAnn
  348            , dfid_inst = DataFamInstDecl { dfid_eqn =
  349                            FamEqn { feqn_ext = noAnn
  350                                   , feqn_tycon = tc'
  351                                   , feqn_bndrs = bndrs'
  352                                   , feqn_pats = typats'
  353                                   , feqn_rhs = defn
  354                                   , feqn_fixity = Prefix } }}}
  355 
  356 cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
  357   = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
  358        ; ksig' <- cvtKind `traverse` ksig
  359        ; con' <- cvtConstr constr
  360        ; derivs' <- cvtDerivs derivs
  361        ; let defn = HsDataDefn { dd_ext = noExtField
  362                                , dd_ND = NewType, dd_cType = Nothing
  363                                , dd_ctxt = mkHsContextMaybe ctxt'
  364                                , dd_kindSig = ksig'
  365                                , dd_cons = [con'], dd_derivs = derivs' }
  366        ; returnJustLA $ InstD noExtField $ DataFamInstD
  367            { dfid_ext = noAnn
  368            , dfid_inst = DataFamInstDecl { dfid_eqn =
  369                            FamEqn { feqn_ext = noAnn
  370                                   , feqn_tycon = tc'
  371                                   , feqn_bndrs = bndrs'
  372                                   , feqn_pats = typats'
  373                                   , feqn_rhs = defn
  374                                   , feqn_fixity = Prefix } }}}
  375 
  376 cvtDec (TySynInstD eqn)
  377   = do  { (L _ eqn') <- cvtTySynEqn eqn
  378         ; returnJustLA $ InstD noExtField $ TyFamInstD
  379             { tfid_ext = noExtField
  380             , tfid_inst = TyFamInstDecl { tfid_xtn = noAnn, tfid_eqn = eqn' } }}
  381 
  382 cvtDec (OpenTypeFamilyD head)
  383   = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
  384        ; returnJustLA $ TyClD noExtField $ FamDecl noExtField $
  385          FamilyDecl noAnn OpenTypeFamily TopLevel tc' tyvars' Prefix result' injectivity'
  386        }
  387 
  388 cvtDec (ClosedTypeFamilyD head eqns)
  389   = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
  390        ; eqns' <- mapM cvtTySynEqn eqns
  391        ; returnJustLA $ TyClD noExtField $ FamDecl noExtField $
  392          FamilyDecl noAnn (ClosedTypeFamily (Just eqns')) TopLevel tc' tyvars' Prefix
  393                            result' injectivity' }
  394 
  395 cvtDec (TH.RoleAnnotD tc roles)
  396   = do { tc' <- tconNameN tc
  397        ; let roles' = map (noLocA . cvtRole) roles
  398        ; returnJustLA
  399                    $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noAnn tc' roles') }
  400 
  401 cvtDec (TH.StandaloneDerivD ds cxt ty)
  402   = do { cxt' <- cvtContext funPrec cxt
  403        ; ds'  <- traverse cvtDerivStrategy ds
  404        ; (L loc ty') <- cvtType ty
  405        ; let inst_ty' = L loc $ mkHsImplicitSigType $
  406                         mkHsQualTy cxt loc cxt' $ L loc ty'
  407        ; returnJustLA $ DerivD noExtField $
  408          DerivDecl { deriv_ext = noAnn
  409                    , deriv_strategy = ds'
  410                    , deriv_type = mkHsWildCardBndrs inst_ty'
  411                    , deriv_overlap_mode = Nothing } }
  412 
  413 cvtDec (TH.DefaultSigD nm typ)
  414   = do { nm' <- vNameN nm
  415        ; ty' <- cvtSigType typ
  416        ; returnJustLA $ Hs.SigD noExtField
  417                       $ ClassOpSig noAnn True [nm'] ty'}
  418 
  419 cvtDec (TH.PatSynD nm args dir pat)
  420   = do { nm'   <- cNameN nm
  421        ; args' <- cvtArgs args
  422        ; dir'  <- cvtDir nm' dir
  423        ; pat'  <- cvtPat pat
  424        ; returnJustLA $ Hs.ValD noExtField $ PatSynBind noExtField $
  425            PSB noAnn nm' args' pat' dir' }
  426   where
  427     cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon noTypeArgs <$> mapM vNameN args
  428     cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameN a1 <*> vNameN a2
  429     cvtArgs (TH.RecordPatSyn sels)
  430       = do { sels' <- mapM (fmap (\ (L li i) -> FieldOcc noExtField (L li i)) . vNameN) sels
  431            ; vars' <- mapM (vNameN . mkNameS . nameBase) sels
  432            ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }
  433 
  434     -- cvtDir :: LocatedN RdrName -> (PatSynDir -> CvtM (HsPatSynDir RdrName))
  435     cvtDir _ Unidir          = return Unidirectional
  436     cvtDir _ ImplBidir       = return ImplicitBidirectional
  437     cvtDir n (ExplBidir cls) =
  438       do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
  439          ; th_origin <- getOrigin
  440          ; return $ ExplicitBidirectional $ mkMatchGroup th_origin (noLocA ms) }
  441 
  442 cvtDec (TH.PatSynSigD nm ty)
  443   = do { nm' <- cNameN nm
  444        ; ty' <- cvtPatSynSigTy ty
  445        ; returnJustLA $ Hs.SigD noExtField $ PatSynSig noAnn [nm'] ty'}
  446 
  447 -- Implicit parameter bindings are handled in cvtLocalDecs and
  448 -- cvtImplicitParamBind. They are not allowed in any other scope, so
  449 -- reaching this case indicates an error.
  450 cvtDec (TH.ImplicitParamBindD _ _)
  451   = failWith (text "Implicit parameter binding only allowed in let or where")
  452 
  453 ----------------
  454 cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
  455 cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)
  456   = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs
  457        ; let outer_bndrs = mkHsOuterFamEqnTyVarBndrs mb_bndrs'
  458        ; (head_ty, args) <- split_ty_app lhs
  459        ; case head_ty of
  460            ConT nm -> do { nm' <- tconNameN nm
  461                          ; rhs' <- cvtType rhs
  462                          ; let args' = map wrap_tyarg args
  463                          ; returnLA
  464                             $ FamEqn { feqn_ext    = noAnn
  465                                      , feqn_tycon  = nm'
  466                                      , feqn_bndrs  = outer_bndrs
  467                                      , feqn_pats   = args'
  468                                      , feqn_fixity = Prefix
  469                                      , feqn_rhs    = rhs' } }
  470            InfixT t1 nm t2 -> do { nm' <- tconNameN nm
  471                                  ; args' <- mapM cvtType [t1,t2]
  472                                  ; rhs' <- cvtType rhs
  473                                  ; returnLA
  474                                       $ FamEqn { feqn_ext    = noAnn
  475                                                , feqn_tycon  = nm'
  476                                                , feqn_bndrs  = outer_bndrs
  477                                                , feqn_pats   =
  478                                                 (map HsValArg args') ++ args
  479                                                , feqn_fixity = Hs.Infix
  480                                                , feqn_rhs    = rhs' } }
  481            _ -> failWith $ text "Invalid type family instance LHS:"
  482                           <+> text (show lhs)
  483         }
  484 
  485 ----------------
  486 cvt_ci_decs :: SDoc -> [TH.Dec]
  487             -> CvtM (LHsBinds GhcPs,
  488                      [LSig GhcPs],
  489                      [LFamilyDecl GhcPs],
  490                      [LTyFamInstDecl GhcPs],
  491                      [LDataFamInstDecl GhcPs])
  492 -- Convert the declarations inside a class or instance decl
  493 -- ie signatures, bindings, and associated types
  494 cvt_ci_decs doc decs
  495   = do  { decs' <- cvtDecs decs
  496         ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'
  497         ; let (adts', no_ats')       = partitionWith is_datafam_inst bind_sig_decs'
  498         ; let (sigs', prob_binds')   = partitionWith is_sig no_ats'
  499         ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'
  500         ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'
  501         ; unless (null bads) (failWith (mkBadDecMsg doc bads))
  502         ; return (listToBag binds', sigs', fams', ats', adts') }
  503 
  504 ----------------
  505 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr ()]
  506              -> CvtM ( LHsContext GhcPs
  507                      , LocatedN RdrName
  508                      , LHsQTyVars GhcPs)
  509 cvt_tycl_hdr cxt tc tvs
  510   = do { cxt' <- cvtContext funPrec cxt
  511        ; tc'  <- tconNameN tc
  512        ; tvs' <- cvtTvs tvs
  513        ; return (cxt', tc', mkHsQTvs tvs')
  514        }
  515 
  516 cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr ()] -> TH.Type
  517                -> CvtM ( LHsContext GhcPs
  518                        , LocatedN RdrName
  519                        , HsOuterFamEqnTyVarBndrs GhcPs
  520                        , HsTyPats GhcPs)
  521 cvt_datainst_hdr cxt bndrs tys
  522   = do { cxt' <- cvtContext funPrec cxt
  523        ; bndrs' <- traverse (mapM cvt_tv) bndrs
  524        ; let outer_bndrs = mkHsOuterFamEqnTyVarBndrs bndrs'
  525        ; (head_ty, args) <- split_ty_app tys
  526        ; case head_ty of
  527           ConT nm -> do { nm' <- tconNameN nm
  528                         ; let args' = map wrap_tyarg args
  529                         ; return (cxt', nm', outer_bndrs, args') }
  530           InfixT t1 nm t2 -> do { nm' <- tconNameN nm
  531                                 ; args' <- mapM cvtType [t1,t2]
  532                                 ; return (cxt', nm', outer_bndrs,
  533                                          ((map HsValArg args') ++ args)) }
  534           _ -> failWith $ text "Invalid type instance header:"
  535                           <+> text (show tys) }
  536 
  537 ----------------
  538 cvt_tyfam_head :: TypeFamilyHead
  539                -> CvtM ( LocatedN RdrName
  540                        , LHsQTyVars GhcPs
  541                        , Hs.LFamilyResultSig GhcPs
  542                        , Maybe (Hs.LInjectivityAnn GhcPs))
  543 
  544 cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)
  545   = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars
  546        ; result' <- cvtFamilyResultSig result
  547        ; injectivity' <- traverse cvtInjectivityAnnotation injectivity
  548        ; return (tc', tyvars', result', injectivity') }
  549 
  550 -------------------------------------------------------------------
  551 --              Partitioning declarations
  552 -------------------------------------------------------------------
  553 
  554 is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
  555 is_fam_decl (L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (L loc d)
  556 is_fam_decl decl = Right decl
  557 
  558 is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
  559 is_tyfam_inst (L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
  560   = Left (L loc d)
  561 is_tyfam_inst decl
  562   = Right decl
  563 
  564 is_datafam_inst :: LHsDecl GhcPs
  565                 -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
  566 is_datafam_inst (L loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))
  567   = Left (L loc d)
  568 is_datafam_inst decl
  569   = Right decl
  570 
  571 is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
  572 is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig)
  573 is_sig decl                    = Right decl
  574 
  575 is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
  576 is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind)
  577 is_bind decl                     = Right decl
  578 
  579 is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec
  580 is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)
  581 is_ip_bind decl             = Right decl
  582 
  583 mkBadDecMsg :: Outputable a => SDoc -> [a] -> SDoc
  584 mkBadDecMsg doc bads
  585   = sep [ text "Illegal declaration(s) in" <+> doc <> colon
  586         , nest 2 (vcat (map Outputable.ppr bads)) ]
  587 
  588 ---------------------------------------------------
  589 --      Data types
  590 ---------------------------------------------------
  591 
  592 cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)
  593 
  594 cvtConstr (NormalC c strtys)
  595   = do  { c'   <- cNameN c
  596         ; tys' <- mapM cvt_arg strtys
  597         ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon noTypeArgs (map hsLinear tys')) }
  598 
  599 cvtConstr (RecC c varstrtys)
  600   = do  { c'    <- cNameN c
  601         ; args' <- mapM cvt_id_arg varstrtys
  602         ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing
  603                                    (RecCon (noLocA args')) }
  604 
  605 cvtConstr (InfixC st1 c st2)
  606   = do  { c'   <- cNameN c
  607         ; st1' <- cvt_arg st1
  608         ; st2' <- cvt_arg st2
  609         ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing
  610                        (InfixCon (hsLinear st1') (hsLinear st2')) }
  611 
  612 cvtConstr (ForallC tvs ctxt con)
  613   = do  { tvs'      <- cvtTvs tvs
  614         ; ctxt'     <- cvtContext funPrec ctxt
  615         ; L _ con'  <- cvtConstr con
  616         ; returnLA $ add_forall tvs' ctxt' con' }
  617   where
  618     add_cxt lcxt         Nothing           = mkHsContextMaybe lcxt
  619     add_cxt (L loc cxt1) (Just (L _ cxt2))
  620       = Just (L loc (cxt1 ++ cxt2))
  621 
  622     add_forall :: [LHsTyVarBndr Hs.Specificity GhcPs] -> LHsContext GhcPs
  623                -> ConDecl GhcPs -> ConDecl GhcPs
  624     add_forall tvs' cxt' con@(ConDeclGADT { con_bndrs = L l outer_bndrs, con_mb_cxt = cxt })
  625       = con { con_bndrs  = L l outer_bndrs'
  626             , con_mb_cxt = add_cxt cxt' cxt }
  627       where
  628         outer_bndrs'
  629           | null all_tvs = mkHsOuterImplicit
  630           | otherwise    = mkHsOuterExplicit noAnn all_tvs
  631 
  632         all_tvs = tvs' ++ outer_exp_tvs
  633 
  634         outer_exp_tvs = hsOuterExplicitBndrs outer_bndrs
  635 
  636     add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })
  637       = con { con_forall = not (null all_tvs)
  638             , con_ex_tvs = all_tvs
  639             , con_mb_cxt = add_cxt cxt' cxt }
  640       where
  641         all_tvs = tvs' ++ ex_tvs
  642 
  643 cvtConstr (GadtC [] _strtys _ty)
  644   = failWith (text "GadtC must have at least one constructor name")
  645 
  646 cvtConstr (GadtC c strtys ty)
  647   = do  { c'      <- mapM cNameN c
  648         ; args    <- mapM cvt_arg strtys
  649         ; ty'     <- cvtType ty
  650         ; returnLA $ mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'}
  651 
  652 cvtConstr (RecGadtC [] _varstrtys _ty)
  653   = failWith (text "RecGadtC must have at least one constructor name")
  654 
  655 cvtConstr (RecGadtC c varstrtys ty)
  656   = do  { c'       <- mapM cNameN c
  657         ; ty'      <- cvtType ty
  658         ; rec_flds <- mapM cvt_id_arg varstrtys
  659         ; returnLA $ mk_gadt_decl c' (RecConGADT (noLocA rec_flds) noHsUniTok) ty' }
  660 
  661 mk_gadt_decl :: [LocatedN RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs
  662              -> ConDecl GhcPs
  663 mk_gadt_decl names args res_ty
  664   = ConDeclGADT { con_g_ext  = noAnn
  665                 , con_names  = names
  666                 , con_bndrs  = noLocA mkHsOuterImplicit
  667                 , con_mb_cxt = Nothing
  668                 , con_g_args = args
  669                 , con_res_ty = res_ty
  670                 , con_doc    = Nothing }
  671 
  672 cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
  673 cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
  674 cvtSrcUnpackedness SourceNoUnpack       = SrcNoUnpack
  675 cvtSrcUnpackedness SourceUnpack         = SrcUnpack
  676 
  677 cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness
  678 cvtSrcStrictness NoSourceStrictness = NoSrcStrict
  679 cvtSrcStrictness SourceLazy         = SrcLazy
  680 cvtSrcStrictness SourceStrict       = SrcStrict
  681 
  682 cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)
  683 cvt_arg (Bang su ss, ty)
  684   = do { ty'' <- cvtType ty
  685        ; let ty' = parenthesizeHsType appPrec ty''
  686              su' = cvtSrcUnpackedness su
  687              ss' = cvtSrcStrictness ss
  688        ; returnLA $ HsBangTy noAnn (HsSrcBang NoSourceText su' ss') ty' }
  689 
  690 cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
  691 cvt_id_arg (i, str, ty)
  692   = do  { L li i' <- vNameN i
  693         ; ty' <- cvt_arg (str,ty)
  694         ; return $ noLocA (ConDeclField
  695                           { cd_fld_ext = noAnn
  696                           , cd_fld_names
  697                               = [L (l2l li) $ FieldOcc noExtField (L li i')]
  698                           , cd_fld_type =  ty'
  699                           , cd_fld_doc = Nothing}) }
  700 
  701 cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
  702 cvtDerivs cs = do { mapM cvtDerivClause cs }
  703 
  704 cvt_fundep :: TH.FunDep -> CvtM (LHsFunDep GhcPs)
  705 cvt_fundep (TH.FunDep xs ys) = do { xs' <- mapM tNameN xs
  706                                   ; ys' <- mapM tNameN ys
  707                                   ; returnLA (Hs.FunDep noAnn xs' ys') }
  708 
  709 
  710 ------------------------------------------
  711 --      Foreign declarations
  712 ------------------------------------------
  713 
  714 cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
  715 cvtForD (ImportF callconv safety from nm ty)
  716   -- the prim and javascript calling conventions do not support headers
  717   -- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess
  718   | callconv == TH.Prim || callconv == TH.JavaScript
  719   = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing
  720                     (CFunction (StaticTarget (SourceText from)
  721                                              (mkFastString from) Nothing
  722                                              True))
  723                     (noLoc $ quotedSourceText from))
  724   | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
  725                                  (mkFastString (TH.nameBase nm))
  726                                  from (noLoc $ quotedSourceText from)
  727   = mk_imp impspec
  728   | otherwise
  729   = failWith $ text (show from) <+> text "is not a valid ccall impent"
  730   where
  731     mk_imp impspec
  732       = do { nm' <- vNameN nm
  733            ; ty' <- cvtSigType ty
  734            ; return (ForeignImport { fd_i_ext = noAnn
  735                                    , fd_name = nm'
  736                                    , fd_sig_ty = ty'
  737                                    , fd_fi = impspec })
  738            }
  739     safety' = case safety of
  740                      Unsafe     -> PlayRisky
  741                      Safe       -> PlaySafe
  742                      Interruptible -> PlayInterruptible
  743 
  744 cvtForD (ExportF callconv as nm ty)
  745   = do  { nm' <- vNameN nm
  746         ; ty' <- cvtSigType ty
  747         ; let e = CExport (noLoc (CExportStatic (SourceText as)
  748                                                 (mkFastString as)
  749                                                 (cvt_conv callconv)))
  750                                                 (noLoc (SourceText as))
  751         ; return $ ForeignExport { fd_e_ext = noAnn
  752                                  , fd_name = nm'
  753                                  , fd_sig_ty = ty'
  754                                  , fd_fe = e } }
  755 
  756 cvt_conv :: TH.Callconv -> CCallConv
  757 cvt_conv TH.CCall      = CCallConv
  758 cvt_conv TH.StdCall    = StdCallConv
  759 cvt_conv TH.CApi       = CApiConv
  760 cvt_conv TH.Prim       = PrimCallConv
  761 cvt_conv TH.JavaScript = JavaScriptCallConv
  762 
  763 ------------------------------------------
  764 --              Pragmas
  765 ------------------------------------------
  766 
  767 cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
  768 cvtPragmaD (InlineP nm inline rm phases)
  769   = do { nm' <- vNameN nm
  770        ; let dflt = dfltActivation inline
  771        ; let src TH.NoInline  = "{-# NOINLINE"
  772              src TH.Inline    = "{-# INLINE"
  773              src TH.Inlinable = "{-# INLINABLE"
  774        ; let ip   = InlinePragma { inl_src    = toSrcTxt inline
  775                                  , inl_inline = cvtInline inline (toSrcTxt inline)
  776                                  , inl_rule   = cvtRuleMatch rm
  777                                  , inl_act    = cvtPhases phases dflt
  778                                  , inl_sat    = Nothing }
  779                     where
  780                      toSrcTxt a = SourceText $ src a
  781        ; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip }
  782 
  783 cvtPragmaD (SpecialiseP nm ty inline phases)
  784   = do { nm' <- vNameN nm
  785        ; ty' <- cvtSigType ty
  786        ; let src TH.NoInline  = "{-# SPECIALISE NOINLINE"
  787              src TH.Inline    = "{-# SPECIALISE INLINE"
  788              src TH.Inlinable = "{-# SPECIALISE INLINE"
  789        ; let (inline', dflt, srcText) = case inline of
  790                Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1,
  791                                 toSrcTxt inline1)
  792                Nothing      -> (NoUserInlinePrag,   AlwaysActive,
  793                                 SourceText "{-# SPECIALISE")
  794                where
  795                 toSrcTxt a = SourceText $ src a
  796        ; let ip = InlinePragma { inl_src    = srcText
  797                                , inl_inline = inline'
  798                                , inl_rule   = Hs.FunLike
  799                                , inl_act    = cvtPhases phases dflt
  800                                , inl_sat    = Nothing }
  801        ; returnJustLA $ Hs.SigD noExtField $ SpecSig noAnn nm' [ty'] ip }
  802 
  803 cvtPragmaD (SpecialiseInstP ty)
  804   = do { ty' <- cvtSigType ty
  805        ; returnJustLA $ Hs.SigD noExtField $
  806          SpecInstSig noAnn (SourceText "{-# SPECIALISE") ty' }
  807 
  808 cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
  809   = do { let nm' = mkFastString nm
  810        ; let act = cvtPhases phases AlwaysActive
  811        ; ty_bndrs' <- traverse cvtTvs ty_bndrs
  812        ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs
  813        ; lhs'   <- cvtl lhs
  814        ; rhs'   <- cvtl rhs
  815        ; returnJustLA $ Hs.RuleD noExtField
  816             $ HsRules { rds_ext = noAnn
  817                       , rds_src = SourceText "{-# RULES"
  818                       , rds_rules = [noLocA $
  819                           HsRule { rd_ext  = noAnn
  820                                  , rd_name = (noLocA (quotedSourceText nm,nm'))
  821                                  , rd_act  = act
  822                                  , rd_tyvs = ty_bndrs'
  823                                  , rd_tmvs = tm_bndrs'
  824                                  , rd_lhs  = lhs'
  825                                  , rd_rhs  = rhs' }] }
  826 
  827           }
  828 
  829 cvtPragmaD (AnnP target exp)
  830   = do { exp' <- cvtl exp
  831        ; target' <- case target of
  832          ModuleAnnotation  -> return ModuleAnnProvenance
  833          TypeAnnotation n  -> do
  834            n' <- tconName n
  835            return (TypeAnnProvenance  (noLocA n'))
  836          ValueAnnotation n -> do
  837            n' <- vcName n
  838            return (ValueAnnProvenance (noLocA n'))
  839        ; returnJustLA $ Hs.AnnD noExtField
  840                      $ HsAnnotation noAnn (SourceText "{-# ANN") target' exp'
  841        }
  842 
  843 cvtPragmaD (LineP line file)
  844   = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))
  845        ; return Nothing
  846        }
  847 cvtPragmaD (CompleteP cls mty)
  848   = do { cls' <- noLoc <$> mapM cNameN cls
  849        ; mty'  <- traverse tconNameN mty
  850        ; returnJustLA $ Hs.SigD noExtField
  851                    $ CompleteMatchSig noAnn NoSourceText cls' mty' }
  852 
  853 dfltActivation :: TH.Inline -> Activation
  854 dfltActivation TH.NoInline = NeverActive
  855 dfltActivation _           = AlwaysActive
  856 
  857 cvtInline :: TH.Inline  -> SourceText -> Hs.InlineSpec
  858 cvtInline TH.NoInline   srcText  = Hs.NoInline  srcText
  859 cvtInline TH.Inline     srcText  = Hs.Inline    srcText
  860 cvtInline TH.Inlinable  srcText  = Hs.Inlinable srcText
  861 
  862 cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
  863 cvtRuleMatch TH.ConLike = Hs.ConLike
  864 cvtRuleMatch TH.FunLike = Hs.FunLike
  865 
  866 cvtPhases :: TH.Phases -> Activation -> Activation
  867 cvtPhases AllPhases       dflt = dflt
  868 cvtPhases (FromPhase i)   _    = ActiveAfter NoSourceText i
  869 cvtPhases (BeforePhase i) _    = ActiveBefore NoSourceText i
  870 
  871 cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)
  872 cvtRuleBndr (RuleVar n)
  873   = do { n' <- vNameN n
  874        ; return $ noLocA $ Hs.RuleBndr noAnn n' }
  875 cvtRuleBndr (TypedRuleVar n ty)
  876   = do { n'  <- vNameN n
  877        ; ty' <- cvtType ty
  878        ; return $ noLocA $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' }
  879 
  880 ---------------------------------------------------
  881 --              Declarations
  882 ---------------------------------------------------
  883 
  884 cvtLocalDecs :: SDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
  885 cvtLocalDecs doc ds
  886   = case partitionWith is_ip_bind ds of
  887       ([], []) -> return (EmptyLocalBinds noExtField)
  888       ([], _) -> do
  889         ds' <- cvtDecs ds
  890         let (binds, prob_sigs) = partitionWith is_bind ds'
  891         let (sigs, bads) = partitionWith is_sig prob_sigs
  892         unless (null bads) (failWith (mkBadDecMsg doc bads))
  893         return (HsValBinds noAnn (ValBinds NoAnnSortKey (listToBag binds) sigs))
  894       (ip_binds, []) -> do
  895         binds <- mapM (uncurry cvtImplicitParamBind) ip_binds
  896         return (HsIPBinds noAnn (IPBinds noExtField binds))
  897       ((_:_), (_:_)) ->
  898         failWith (text "Implicit parameters mixed with other bindings")
  899 
  900 cvtClause :: HsMatchContext GhcPs
  901           -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
  902 cvtClause ctxt (Clause ps body wheres)
  903   = do  { ps' <- cvtPats ps
  904         ; let pps = map (parenthesizePat appPrec) ps'
  905         ; g'  <- cvtGuard body
  906         ; ds' <- cvtLocalDecs (text "a where clause") wheres
  907         ; returnLA $ Hs.Match noAnn ctxt pps (GRHSs emptyComments g' ds') }
  908 
  909 cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
  910 cvtImplicitParamBind n e = do
  911     n' <- wrapL (ipName n)
  912     e' <- cvtl e
  913     returnLA (IPBind noAnn (Left (reLocA n')) e')
  914 
  915 -------------------------------------------------------------------
  916 --              Expressions
  917 -------------------------------------------------------------------
  918 
  919 cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
  920 cvtl e = wrapLA (cvt e)
  921   where
  922     cvt (VarE s)   = do { s' <- vName s; return $ HsVar noExtField (noLocA s') }
  923     cvt (ConE s)   = do { s' <- cName s; return $ HsVar noExtField (noLocA s') }
  924     cvt (LitE l)
  925       | overloadedLit l = go cvtOverLit (HsOverLit noComments)
  926                              (hsOverLitNeedsParens appPrec)
  927       | otherwise       = go cvtLit (HsLit noComments)
  928                              (hsLitNeedsParens appPrec)
  929       where
  930         go :: (Lit -> CvtM (l GhcPs))
  931            -> (l GhcPs -> HsExpr GhcPs)
  932            -> (l GhcPs -> Bool)
  933            -> CvtM (HsExpr GhcPs)
  934         go cvt_lit mk_expr is_compound_lit = do
  935           l' <- cvt_lit l
  936           let e' = mk_expr l'
  937           return $ if is_compound_lit l' then gHsPar (noLocA e') else e'
  938     cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
  939                                    ; return $ HsApp noComments (mkLHsPar x')
  940                                                           (mkLHsPar y')}
  941     cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y
  942                                    ; return $ HsApp noComments (mkLHsPar x')
  943                                                           (mkLHsPar y')}
  944     cvt (AppTypeE e t) = do { e' <- cvtl e
  945                             ; t' <- cvtType t
  946                             ; let tp = parenthesizeHsType appPrec t'
  947                             ; return $ HsAppType noSrcSpan e'
  948                                      $ mkHsWildCardBndrs tp }
  949     cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its
  950                                -- own expression to avoid pretty-printing
  951                                -- oddities that can result from zero-argument
  952                                -- lambda expressions. See #13856.
  953     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
  954                             ; let pats = map (parenthesizePat appPrec) ps'
  955                             ; th_origin <- getOrigin
  956                             ; return $ HsLam noExtField (mkMatchGroup th_origin
  957                                              (noLocA [mkSimpleMatch LambdaExpr
  958                                              pats e']))}
  959     cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch CaseAlt) ms
  960                             ; th_origin <- getOrigin
  961                             ; return $ HsLamCase noAnn
  962                                                    (mkMatchGroup th_origin (noLocA ms'))
  963                             }
  964     cvt (TupE es)        = cvt_tup es Boxed
  965     cvt (UnboxedTupE es) = cvt_tup es Unboxed
  966     cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
  967                                        ; unboxedSumChecks alt arity
  968                                        ; return $ ExplicitSum noAnn
  969                                                                    alt arity e'}
  970     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
  971                             ; return $ mkHsIf x' y' z' noAnn }
  972     cvt (MultiIfE alts)
  973       | null alts      = failWith (text "Multi-way if-expression with no alternatives")
  974       | otherwise      = do { alts' <- mapM cvtpair alts
  975                             ; return $ HsMultiIf noAnn alts' }
  976     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds
  977                             ; e' <- cvtl e; return $ HsLet noAnn noHsTok ds' noHsTok e'}
  978     cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
  979                             ; th_origin <- getOrigin
  980                             ; return $ HsCase noAnn e'
  981                                                  (mkMatchGroup th_origin (noLocA ms')) }
  982     cvt (DoE m ss)     = cvtHsDo (DoExpr (mk_mod <$> m)) ss
  983     cvt (MDoE m ss)    = cvtHsDo (MDoExpr (mk_mod <$> m)) ss
  984     cvt (CompE ss)     = cvtHsDo ListComp ss
  985     cvt (ArithSeqE dd) = do { dd' <- cvtDD dd
  986                             ; return $ ArithSeq noAnn Nothing dd' }
  987     cvt (ListE xs)
  988       | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s)
  989                                           ; return (HsLit noComments l') }
  990              -- Note [Converting strings]
  991       | otherwise       = do { xs' <- mapM cvtl xs
  992                              ; return $ ExplicitList noAnn xs'
  993                              }
  994 
  995     -- Infix expressions
  996     cvt (InfixE (Just x) s (Just y)) = ensureValidOpExp s $
  997       do { x' <- cvtl x
  998          ; s' <- cvtl s
  999          ; y' <- cvtl y
 1000          ; let px = parenthesizeHsExpr opPrec x'
 1001                py = parenthesizeHsExpr opPrec y'
 1002          ; wrapParLA gHsPar
 1003            $ OpApp noAnn px s' py }
 1004            -- Parenthesise both arguments and result,
 1005            -- to ensure this operator application does
 1006            -- does not get re-associated
 1007            -- See Note [Operator association]
 1008     cvt (InfixE Nothing  s (Just y)) = ensureValidOpExp s $
 1009                                        do { s' <- cvtl s; y' <- cvtl y
 1010                                           ; wrapParLA gHsPar $
 1011                                                           SectionR noComments s' y' }
 1012                                             -- See Note [Sections in HsSyn] in GHC.Hs.Expr
 1013     cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $
 1014                                        do { x' <- cvtl x; s' <- cvtl s
 1015                                           ; wrapParLA gHsPar $
 1016                                                           SectionL noComments x' s' }
 1017 
 1018     cvt (InfixE Nothing  s Nothing ) = ensureValidOpExp s $
 1019                                        do { s' <- cvtl s
 1020                                           ; return $ gHsPar s' }
 1021                                        -- Can I indicate this is an infix thing?
 1022                                        -- Note [Dropping constructors]
 1023 
 1024     cvt (UInfixE x s y)  = ensureValidOpExp s $
 1025                            do { x' <- cvtl x
 1026                               ; let x'' = case unLoc x' of
 1027                                             OpApp {} -> x'
 1028                                             _ -> mkLHsPar x'
 1029                               ; cvtOpApp x'' s y } --  Note [Converting UInfix]
 1030 
 1031     cvt (ParensE e)      = do { e' <- cvtl e; return $ gHsPar e' }
 1032     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtSigType t
 1033                               ; let pe = parenthesizeHsExpr sigPrec e'
 1034                               ; return $ ExprWithTySig noAnn pe (mkHsWildCardBndrs t') }
 1035     cvt (RecConE c flds) = do { c' <- cNameN c
 1036                               ; flds' <- mapM (cvtFld (mkFieldOcc . noLocA)) flds
 1037                               ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) noAnn }
 1038     cvt (RecUpdE e flds) = do { e' <- cvtl e
 1039                               ; flds'
 1040                                   <- mapM (cvtFld (mkAmbiguousFieldOcc . noLocA))
 1041                                            flds
 1042                               ; return $ RecordUpd noAnn e' (Left flds') }
 1043     cvt (StaticE e)      = fmap (HsStatic noAnn) $ cvtl e
 1044     cvt (UnboundVarE s)  = do -- Use of 'vcName' here instead of 'vName' is
 1045                               -- important, because UnboundVarE may contain
 1046                               -- constructor names - see #14627.
 1047                               { s' <- vcName s
 1048                               ; return $ HsVar noExtField (noLocA s') }
 1049     cvt (LabelE s)       = return $ HsOverLabel noComments (fsLit s)
 1050     cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' }
 1051     cvt (GetFieldE exp f) = do { e' <- cvtl exp
 1052                                ; return $ HsGetField noComments e' (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (fsLit f)))) }
 1053     cvt (ProjectionE xs) = return $ HsProjection noAnn $ map (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . fsLit) xs
 1054 
 1055 {- | #16895 Ensure an infix expression's operator is a variable/constructor.
 1056 Consider this example:
 1057 
 1058   $(uInfixE [|1|] [|id id|] [|2|])
 1059 
 1060 This infix expression is obviously ill-formed so we use this helper function
 1061 to reject such programs outright.
 1062 
 1063 The constructors `ensureValidOpExp` permits should be in sync with `pprInfixExp`
 1064 in Language.Haskell.TH.Ppr from the template-haskell library.
 1065 -}
 1066 ensureValidOpExp :: TH.Exp -> CvtM a -> CvtM a
 1067 ensureValidOpExp (VarE _n) m = m
 1068 ensureValidOpExp (ConE _n) m = m
 1069 ensureValidOpExp (UnboundVarE _n) m = m
 1070 ensureValidOpExp _e _m =
 1071     failWith (text "Non-variable expression is not allowed in an infix expression")
 1072 
 1073 {- Note [Dropping constructors]
 1074 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1075 When we drop constructors from the input, we must insert parentheses around the
 1076 argument. For example:
 1077 
 1078   UInfixE x * (AppE (InfixE (Just y) + Nothing) z)
 1079 
 1080 If we convert the InfixE expression to an operator section but don't insert
 1081 parentheses, the above expression would be reassociated to
 1082 
 1083   OpApp (OpApp x * y) + z
 1084 
 1085 which we don't want.
 1086 -}
 1087 
 1088 cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)
 1089        -> CvtM (LHsFieldBind GhcPs (LocatedAn NoEpAnns t) (LHsExpr GhcPs))
 1090 cvtFld f (v,e)
 1091   = do  { v' <- vNameL v; e' <- cvtl e
 1092         ; return (noLocA $ HsFieldBind { hfbAnn = noAnn
 1093                                        , hfbLHS = la2la $ fmap f v'
 1094                                        , hfbRHS = e'
 1095                                        , hfbPun = False}) }
 1096 
 1097 cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)
 1098 cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
 1099 cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
 1100 cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
 1101 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
 1102 
 1103 cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)
 1104 cvt_tup es boxity = do { let cvtl_maybe Nothing  = return (missingTupArg noAnn)
 1105                              cvtl_maybe (Just e) = fmap (Present noAnn) (cvtl e)
 1106                        ; es' <- mapM cvtl_maybe es
 1107                        ; return $ ExplicitTuple
 1108                                     noAnn
 1109                                     es'
 1110                                     boxity }
 1111 
 1112 {- Note [Operator association]
 1113 We must be quite careful about adding parens:
 1114   * Infix (UInfix ...) op arg      Needs parens round the first arg
 1115   * Infix (Infix ...) op arg       Needs parens round the first arg
 1116   * UInfix (UInfix ...) op arg     No parens for first arg
 1117   * UInfix (Infix ...) op arg      Needs parens round first arg
 1118 
 1119 
 1120 Note [Converting UInfix]
 1121 ~~~~~~~~~~~~~~~~~~~~~~~~
 1122 When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust
 1123 the trees to reflect the fixities of the underlying operators:
 1124 
 1125   UInfixE x * (UInfixE y + z) ---> (x * y) + z
 1126 
 1127 This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and
 1128 @mkHsOpTyRn@ in GHC.Rename.HsType), which expects that the input will be completely
 1129 right-biased for types and left-biased for everything else. So we left-bias the
 1130 trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.
 1131 
 1132 Sample input:
 1133 
 1134   UInfixE
 1135    (UInfixE x op1 y)
 1136    op2
 1137    (UInfixE z op3 w)
 1138 
 1139 Sample output:
 1140 
 1141   OpApp
 1142     (OpApp
 1143       (OpApp x op1 y)
 1144       op2
 1145       z)
 1146     op3
 1147     w
 1148 
 1149 The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this
 1150 biasing.
 1151 -}
 1152 
 1153 {- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
 1154 The produced tree of infix expressions will be left-biased, provided @x@ is.
 1155 
 1156 We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis
 1157 is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that
 1158 this holds for both branches (of @cvtOpApp@), provided we assume it holds for
 1159 the recursive calls to @cvtOpApp@.
 1160 
 1161 When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased
 1162 since we have already run @cvtl@ on it.
 1163 -}
 1164 cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs)
 1165 cvtOpApp x op1 (UInfixE y op2 z)
 1166   = do { l <- wrapLA $ cvtOpApp x op1 y
 1167        ; cvtOpApp l op2 z }
 1168 cvtOpApp x op y
 1169   = do { op' <- cvtl op
 1170        ; y' <- cvtl y
 1171        ; return (OpApp noAnn x op' y') }
 1172 
 1173 -------------------------------------
 1174 --      Do notation and statements
 1175 -------------------------------------
 1176 
 1177 cvtHsDo :: HsDoFlavour -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
 1178 cvtHsDo do_or_lc stmts
 1179   | null stmts = failWith (text "Empty stmt list in do-block")
 1180   | otherwise
 1181   = do  { stmts' <- cvtStmts stmts
 1182         ; let Just (stmts'', last') = snocView stmts'
 1183 
 1184         ; last'' <- case last' of
 1185                     (L loc (BodyStmt _ body _ _))
 1186                       -> return (L loc (mkLastStmt body))
 1187                     _ -> failWith (bad_last last')
 1188 
 1189         ; return $ HsDo noAnn do_or_lc (noLocA (stmts'' ++ [last''])) }
 1190   where
 1191     bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAHsDoFlavour do_or_lc <> colon
 1192                          , nest 2 $ Outputable.ppr stmt
 1193                          , text "(It should be an expression.)" ]
 1194 
 1195 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)]
 1196 cvtStmts = mapM cvtStmt
 1197 
 1198 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))
 1199 cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnLA $ mkBodyStmt e' }
 1200 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnLA $ mkPsBindStmt noAnn p' e' }
 1201 cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (text "a let binding") ds
 1202                             ; returnLA $ LetStmt noAnn ds' }
 1203 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss
 1204                             ; returnLA $ ParStmt noExtField dss' noExpr noSyntaxExpr }
 1205   where
 1206     cvt_one ds = do { ds' <- cvtStmts ds
 1207                     ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) }
 1208 cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnLA (mkRecStmt noAnn (noLocA ss')) }
 1209 
 1210 cvtMatch :: HsMatchContext GhcPs
 1211          -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
 1212 cvtMatch ctxt (TH.Match p body decs)
 1213   = do  { p' <- cvtPat p
 1214         ; let lp = case p' of
 1215                      (L loc SigPat{}) -> L loc (gParPat p') -- #14875
 1216                      _                -> p'
 1217         ; g' <- cvtGuard body
 1218         ; decs' <- cvtLocalDecs (text "a where clause") decs
 1219         ; returnLA $ Hs.Match noAnn ctxt [lp] (GRHSs emptyComments g' decs') }
 1220 
 1221 cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
 1222 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
 1223 cvtGuard (NormalB e)      = do { e' <- cvtl e
 1224                                ; g' <- returnLA $ GRHS noAnn [] e'; return [g'] }
 1225 
 1226 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
 1227 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
 1228                               ; g' <- returnLA $ mkBodyStmt ge'
 1229                               ; returnLA $ GRHS noAnn [g'] rhs' }
 1230 cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 1231                               ; returnLA $ GRHS noAnn gs' rhs' }
 1232 
 1233 cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
 1234 cvtOverLit (IntegerL i)
 1235   = do { force i; return $ mkHsIntegral   (mkIntegralLit i) }
 1236 cvtOverLit (RationalL r)
 1237   = do { force r; return $ mkHsFractional (mkTHFractionalLit r) }
 1238 cvtOverLit (StringL s)
 1239   = do { let { s' = mkFastString s }
 1240        ; force s'
 1241        ; return $ mkHsIsString (quotedSourceText s) s'
 1242        }
 1243 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
 1244 -- An Integer is like an (overloaded) '3' in a Haskell source program
 1245 -- Similarly 3.5 for fractionals
 1246 
 1247 {- Note [Converting strings]
 1248 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1249 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
 1250 a string literal for "xy".  Of course, we might hope to get
 1251 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
 1252 if it isn't a literal string
 1253 -}
 1254 
 1255 allCharLs :: [TH.Exp] -> Maybe String
 1256 -- Note [Converting strings]
 1257 -- NB: only fire up this setup for a non-empty list, else
 1258 --     there's a danger of returning "" for [] :: [Int]!
 1259 allCharLs xs
 1260   = case xs of
 1261       LitE (CharL c) : ys -> go [c] ys
 1262       _                   -> Nothing
 1263   where
 1264     go cs []                    = Just (reverse cs)
 1265     go cs (LitE (CharL c) : ys) = go (c:cs) ys
 1266     go _  _                     = Nothing
 1267 
 1268 cvtLit :: Lit -> CvtM (HsLit GhcPs)
 1269 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim NoSourceText i }
 1270 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim NoSourceText w }
 1271 cvtLit (FloatPrimL f)
 1272   = do { force f; return $ HsFloatPrim noExtField (mkTHFractionalLit f) }
 1273 cvtLit (DoublePrimL f)
 1274   = do { force f; return $ HsDoublePrim noExtField (mkTHFractionalLit f) }
 1275 cvtLit (CharL c)       = do { force c; return $ HsChar NoSourceText c }
 1276 cvtLit (CharPrimL c)   = do { force c; return $ HsCharPrim NoSourceText c }
 1277 cvtLit (StringL s)     = do { let { s' = mkFastString s }
 1278                             ; force s'
 1279                             ; return $ HsString (quotedSourceText s) s' }
 1280 cvtLit (StringPrimL s) = do { let { !s' = BS.pack s }
 1281                             ; return $ HsStringPrim NoSourceText s' }
 1282 cvtLit (BytesPrimL (Bytes fptr off sz)) = do
 1283   let bs = unsafePerformIO $ withForeignPtr fptr $ \ptr ->
 1284              BS.packCStringLen (ptr `plusPtr` fromIntegral off, fromIntegral sz)
 1285   force bs
 1286   return $ HsStringPrim NoSourceText bs
 1287 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
 1288         -- cvtLit should not be called on IntegerL, RationalL
 1289         -- That precondition is established right here in
 1290         -- "GHC.ThToHs", hence panic
 1291 
 1292 quotedSourceText :: String -> SourceText
 1293 quotedSourceText s = SourceText $ "\"" ++ s ++ "\""
 1294 
 1295 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]
 1296 cvtPats pats = mapM cvtPat pats
 1297 
 1298 cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)
 1299 cvtPat pat = wrapLA (cvtp pat)
 1300 
 1301 cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs)
 1302 cvtp (TH.LitP l)
 1303   | overloadedLit l    = do { l' <- cvtOverLit l
 1304                             ; return (mkNPat (noLocA l') Nothing noAnn) }
 1305                                   -- Not right for negative patterns;
 1306                                   -- need to think about that!
 1307   | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' }
 1308 cvtp (TH.VarP s)       = do { s' <- vName s
 1309                             ; return $ Hs.VarPat noExtField (noLocA s') }
 1310 cvtp (TupP ps)         = do { ps' <- cvtPats ps
 1311                             ; return $ TuplePat noAnn ps' Boxed }
 1312 cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps
 1313                             ; return $ TuplePat noAnn ps' Unboxed }
 1314 cvtp (UnboxedSumP p alt arity)
 1315                        = do { p' <- cvtPat p
 1316                             ; unboxedSumChecks alt arity
 1317                             ; return $ SumPat noAnn p' alt arity }
 1318 cvtp (ConP s ts ps)    = do { s' <- cNameN s
 1319                             ; ps' <- cvtPats ps
 1320                             ; ts' <- mapM cvtType ts
 1321                             ; let pps = map (parenthesizePat appPrec) ps'
 1322                             ; return $ ConPat
 1323                                 { pat_con_ext = noAnn
 1324                                 , pat_con = s'
 1325                                 , pat_args = PrefixCon (map (mkHsPatSigType noAnn) ts') pps
 1326                                 }
 1327                             }
 1328 cvtp (InfixP p1 s p2)  = do { s' <- cNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2
 1329                             ; wrapParLA gParPat $
 1330                               ConPat
 1331                                 { pat_con_ext = noAnn
 1332                                 , pat_con = s'
 1333                                 , pat_args = InfixCon
 1334                                     (parenthesizePat opPrec p1')
 1335                                     (parenthesizePat opPrec p2')
 1336                                 }
 1337                             }
 1338                             -- See Note [Operator association]
 1339 cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
 1340 cvtp (ParensP p)       = do { p' <- cvtPat p;
 1341                             ; case unLoc p' of  -- may be wrapped ConPatIn
 1342                                 ParPat {} -> return $ unLoc p'
 1343                                 _         -> return $ gParPat p' }
 1344 cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noAnn p' }
 1345 cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noAnn p' }
 1346 cvtp (TH.AsP s p)      = do { s' <- vNameN s; p' <- cvtPat p
 1347                             ; return $ AsPat noAnn s' p' }
 1348 cvtp TH.WildP          = return $ WildPat noExtField
 1349 cvtp (RecP c fs)       = do { c' <- cNameN c; fs' <- mapM cvtPatFld fs
 1350                             ; return $ ConPat
 1351                                 { pat_con_ext = noAnn
 1352                                 , pat_con = c'
 1353                                 , pat_args = Hs.RecCon $ HsRecFields fs' Nothing
 1354                                 }
 1355                             }
 1356 cvtp (ListP ps)        = do { ps' <- cvtPats ps
 1357                             ; return
 1358                                    $ ListPat noAnn ps'}
 1359 cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
 1360                             ; return $ SigPat noAnn p' (mkHsPatSigType noAnn t') }
 1361 cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p
 1362                             ; return $ ViewPat noAnn e' p'}
 1363 
 1364 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
 1365 cvtPatFld (s,p)
 1366   = do  { L ls s' <- vNameN s
 1367         ; p' <- cvtPat p
 1368         ; return (noLocA $ HsFieldBind { hfbAnn = noAnn
 1369                                        , hfbLHS
 1370                                           = L (l2l ls) $ mkFieldOcc (L (l2l ls) s')
 1371                                        , hfbRHS = p'
 1372                                        , hfbPun = False}) }
 1373 
 1374 {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
 1375 The produced tree of infix patterns will be left-biased, provided @x@ is.
 1376 
 1377 See the @cvtOpApp@ documentation for how this function works.
 1378 -}
 1379 cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs)
 1380 cvtOpAppP x op1 (UInfixP y op2 z)
 1381   = do { l <- wrapLA $ cvtOpAppP x op1 y
 1382        ; cvtOpAppP l op2 z }
 1383 cvtOpAppP x op y
 1384   = do { op' <- cNameN op
 1385        ; y' <- cvtPat y
 1386        ; return $ ConPat
 1387           { pat_con_ext = noAnn
 1388           , pat_con = op'
 1389           , pat_args = InfixCon x y'
 1390           }
 1391        }
 1392 
 1393 -----------------------------------------------------------
 1394 --      Types and type variables
 1395 
 1396 class CvtFlag flag flag' | flag -> flag' where
 1397   cvtFlag :: flag -> flag'
 1398 
 1399 instance CvtFlag () () where
 1400   cvtFlag () = ()
 1401 
 1402 instance CvtFlag TH.Specificity Hs.Specificity where
 1403   cvtFlag TH.SpecifiedSpec = Hs.SpecifiedSpec
 1404   cvtFlag TH.InferredSpec  = Hs.InferredSpec
 1405 
 1406 cvtTvs :: CvtFlag flag flag' => [TH.TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
 1407 cvtTvs tvs = mapM cvt_tv tvs
 1408 
 1409 cvt_tv :: CvtFlag flag flag' => (TH.TyVarBndr flag) -> CvtM (LHsTyVarBndr flag' GhcPs)
 1410 cvt_tv (TH.PlainTV nm fl)
 1411   = do { nm' <- tNameN nm
 1412        ; let fl' = cvtFlag fl
 1413        ; returnLA $ UserTyVar noAnn fl' nm' }
 1414 cvt_tv (TH.KindedTV nm fl ki)
 1415   = do { nm' <- tNameN nm
 1416        ; let fl' = cvtFlag fl
 1417        ; ki' <- cvtKind ki
 1418        ; returnLA $ KindedTyVar noAnn fl' nm' ki' }
 1419 
 1420 cvtRole :: TH.Role -> Maybe Coercion.Role
 1421 cvtRole TH.NominalR          = Just Coercion.Nominal
 1422 cvtRole TH.RepresentationalR = Just Coercion.Representational
 1423 cvtRole TH.PhantomR          = Just Coercion.Phantom
 1424 cvtRole TH.InferR            = Nothing
 1425 
 1426 cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs)
 1427 cvtContext p tys = do { preds' <- mapM cvtPred tys
 1428                       ; parenthesizeHsContext p <$> returnLA preds' }
 1429 
 1430 cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)
 1431 cvtPred = cvtType
 1432 
 1433 cvtDerivClauseTys :: TH.Cxt -> CvtM (LDerivClauseTys GhcPs)
 1434 cvtDerivClauseTys tys
 1435   = do { tys' <- mapM cvtSigType tys
 1436          -- Since TH.Cxt doesn't indicate the presence or absence of
 1437          -- parentheses in a deriving clause, we have to choose between
 1438          -- DctSingle and DctMulti somewhat arbitrarily. We opt to use DctMulti
 1439          -- unless the TH.Cxt is a singleton list whose type is a bare type
 1440          -- constructor with no arguments.
 1441        ; case tys' of
 1442            [ty'@(L l (HsSig { sig_bndrs = HsOuterImplicit{}
 1443                             , sig_body  = L _ (HsTyVar _ NotPromoted _) }))]
 1444                  -> return $ L (l2l l) $ DctSingle noExtField ty'
 1445            _     -> returnLA $ DctMulti noExtField tys' }
 1446 
 1447 cvtDerivClause :: TH.DerivClause
 1448                -> CvtM (LHsDerivingClause GhcPs)
 1449 cvtDerivClause (TH.DerivClause ds tys)
 1450   = do { tys' <- cvtDerivClauseTys tys
 1451        ; ds'  <- traverse cvtDerivStrategy ds
 1452        ; returnLA $ HsDerivingClause noAnn ds' tys' }
 1453 
 1454 cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)
 1455 cvtDerivStrategy TH.StockStrategy    = returnLA (Hs.StockStrategy noAnn)
 1456 cvtDerivStrategy TH.AnyclassStrategy = returnLA (Hs.AnyclassStrategy noAnn)
 1457 cvtDerivStrategy TH.NewtypeStrategy  = returnLA (Hs.NewtypeStrategy noAnn)
 1458 cvtDerivStrategy (TH.ViaStrategy ty) = do
 1459   ty' <- cvtSigType ty
 1460   returnLA $ Hs.ViaStrategy (XViaStrategyPs noAnn ty')
 1461 
 1462 cvtType :: TH.Type -> CvtM (LHsType GhcPs)
 1463 cvtType = cvtTypeKind "type"
 1464 
 1465 cvtSigType :: TH.Type -> CvtM (LHsSigType GhcPs)
 1466 cvtSigType = cvtSigTypeKind "type"
 1467 
 1468 -- | Convert a Template Haskell 'Type' to an 'LHsSigType'. To avoid duplicating
 1469 -- the logic in 'cvtTypeKind' here, we simply reuse 'cvtTypeKind' and perform
 1470 -- surgery on the 'LHsType' it returns to turn it into an 'LHsSigType'.
 1471 cvtSigTypeKind :: String -> TH.Type -> CvtM (LHsSigType GhcPs)
 1472 cvtSigTypeKind ty_str ty = do
 1473   ty' <- cvtTypeKind ty_str ty
 1474   pure $ hsTypeToHsSigType ty'
 1475 
 1476 cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs)
 1477 cvtTypeKind ty_str ty
 1478   = do { (head_ty, tys') <- split_ty_app ty
 1479        ; let m_normals = mapM extract_normal tys'
 1480                                 where extract_normal (HsValArg ty) = Just ty
 1481                                       extract_normal _ = Nothing
 1482 
 1483        ; case head_ty of
 1484            TupleT n
 1485             | Just normals <- m_normals
 1486             , normals `lengthIs` n         -- Saturated
 1487             -> returnLA (HsTupleTy noAnn HsBoxedOrConstraintTuple normals)
 1488             | otherwise
 1489             -> mk_apps
 1490                (HsTyVar noAnn NotPromoted
 1491                                      (noLocA (getRdrName (tupleTyCon Boxed n))))
 1492                tys'
 1493            UnboxedTupleT n
 1494              | Just normals <- m_normals
 1495              , normals `lengthIs` n               -- Saturated
 1496              -> returnLA (HsTupleTy noAnn HsUnboxedTuple normals)
 1497              | otherwise
 1498              -> mk_apps
 1499                 (HsTyVar noAnn NotPromoted
 1500                                    (noLocA (getRdrName (tupleTyCon Unboxed n))))
 1501                 tys'
 1502            UnboxedSumT n
 1503              | n < 2
 1504             -> failWith $
 1505                    vcat [ text "Illegal sum arity:" <+> text (show n)
 1506                         , nest 2 $
 1507                             text "Sums must have an arity of at least 2" ]
 1508              | Just normals <- m_normals
 1509              , normals `lengthIs` n -- Saturated
 1510              -> returnLA (HsSumTy noAnn normals)
 1511              | otherwise
 1512              -> mk_apps
 1513                 (HsTyVar noAnn NotPromoted (noLocA (getRdrName (sumTyCon n))))
 1514                 tys'
 1515            ArrowT
 1516              | Just normals <- m_normals
 1517              , [x',y'] <- normals -> do
 1518                  x'' <- case unLoc x' of
 1519                           HsFunTy{}    -> returnLA (HsParTy noAnn x')
 1520                           HsForAllTy{} -> returnLA (HsParTy noAnn x') -- #14646
 1521                           HsQualTy{}   -> returnLA (HsParTy noAnn x') -- #15324
 1522                           _            -> return $
 1523                                           parenthesizeHsType sigPrec x'
 1524                  let y'' = parenthesizeHsType sigPrec y'
 1525                  returnLA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x'' y'')
 1526              | otherwise
 1527              -> mk_apps
 1528                 (HsTyVar noAnn NotPromoted (noLocA (getRdrName unrestrictedFunTyCon)))
 1529                 tys'
 1530            MulArrowT
 1531              | Just normals <- m_normals
 1532              , [w',x',y'] <- normals -> do
 1533                  x'' <- case unLoc x' of
 1534                           HsFunTy{}    -> returnLA (HsParTy noAnn x')
 1535                           HsForAllTy{} -> returnLA (HsParTy noAnn x') -- #14646
 1536                           HsQualTy{}   -> returnLA (HsParTy noAnn x') -- #15324
 1537                           _            -> return $
 1538                                           parenthesizeHsType sigPrec x'
 1539                  let y'' = parenthesizeHsType sigPrec y'
 1540                      w'' = hsTypeToArrow w'
 1541                  returnLA (HsFunTy noAnn w'' x'' y'')
 1542              | otherwise
 1543              -> mk_apps
 1544                 (HsTyVar noAnn NotPromoted (noLocA (getRdrName funTyCon)))
 1545                 tys'
 1546            ListT
 1547              | Just normals <- m_normals
 1548              , [x'] <- normals ->
 1549                 returnLA (HsListTy noAnn x')
 1550              | otherwise
 1551              -> mk_apps
 1552                 (HsTyVar noAnn NotPromoted (noLocA (getRdrName listTyCon)))
 1553                 tys'
 1554 
 1555            VarT nm -> do { nm' <- tNameN nm
 1556                          ; mk_apps (HsTyVar noAnn NotPromoted nm') tys' }
 1557            ConT nm -> do { nm' <- tconName nm
 1558                          ; let prom = name_promotedness nm'
 1559                          ; mk_apps (HsTyVar noAnn prom (noLocA nm')) tys'}
 1560 
 1561            ForallT tvs cxt ty
 1562              | null tys'
 1563              -> do { tvs' <- cvtTvs tvs
 1564                    ; cxt' <- cvtContext funPrec cxt
 1565                    ; ty'  <- cvtType ty
 1566                    ; loc <- getL
 1567                    ; let loc' = noAnnSrcSpan loc
 1568                    ; let tele   = mkHsForAllInvisTele noAnn tvs'
 1569                          hs_ty  = mkHsForAllTy loc' tele rho_ty
 1570                          rho_ty = mkHsQualTy cxt loc' cxt' ty'
 1571 
 1572                    ; return hs_ty }
 1573 
 1574            ForallVisT tvs ty
 1575              | null tys'
 1576              -> do { tvs' <- cvtTvs tvs
 1577                    ; ty'  <- cvtType ty
 1578                    ; loc  <- getL
 1579                    ; let loc' = noAnnSrcSpan loc
 1580                    ; let tele = mkHsForAllVisTele noAnn tvs'
 1581                    ; pure $ mkHsForAllTy loc' tele ty' }
 1582 
 1583            SigT ty ki
 1584              -> do { ty' <- cvtType ty
 1585                    ; ki' <- cvtKind ki
 1586                    ; mk_apps (HsKindSig noAnn ty' ki') tys'
 1587                    }
 1588 
 1589            LitT lit
 1590              -> mk_apps (HsTyLit noExtField (cvtTyLit lit)) tys'
 1591 
 1592            WildCardT
 1593              -> mk_apps mkAnonWildCardTy tys'
 1594 
 1595            InfixT t1 s t2
 1596              -> do { s'  <- tconName s
 1597                    ; t1' <- cvtType t1
 1598                    ; t2' <- cvtType t2
 1599                    ; let prom = name_promotedness s'
 1600                    ; mk_apps
 1601                       (HsTyVar noAnn prom (noLocA s'))
 1602                       ([HsValArg t1', HsValArg t2'] ++ tys')
 1603                    }
 1604 
 1605            UInfixT t1 s t2
 1606              -> do { t2' <- cvtType t2
 1607                    ; t <- cvtOpAppT t1 s t2'
 1608                    ; mk_apps (unLoc t) tys'
 1609                    } -- Note [Converting UInfix]
 1610 
 1611            ParensT t
 1612              -> do { t' <- cvtType t
 1613                    ; mk_apps (HsParTy noAnn t') tys'
 1614                    }
 1615 
 1616            PromotedT nm -> do { nm' <- cName nm
 1617                               ; mk_apps (HsTyVar noAnn IsPromoted
 1618                                          (noLocA nm'))
 1619                                         tys' }
 1620                  -- Promoted data constructor; hence cName
 1621 
 1622            PromotedTupleT n
 1623               | Just normals <- m_normals
 1624               , normals `lengthIs` n   -- Saturated
 1625               -> returnLA (HsExplicitTupleTy noAnn normals)
 1626               | otherwise
 1627               -> mk_apps
 1628                  (HsTyVar noAnn IsPromoted
 1629                                    (noLocA (getRdrName (tupleDataCon Boxed n))))
 1630                  tys'
 1631 
 1632            PromotedNilT
 1633              -> mk_apps (HsExplicitListTy noAnn IsPromoted []) tys'
 1634 
 1635            PromotedConsT  -- See Note [Representing concrete syntax in types]
 1636                           -- in Language.Haskell.TH.Syntax
 1637               | Just normals <- m_normals
 1638               , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals
 1639               -> returnLA (HsExplicitListTy noAnn ip (ty1:tys2))
 1640               | otherwise
 1641               -> mk_apps
 1642                  (HsTyVar noAnn IsPromoted (noLocA (getRdrName consDataCon)))
 1643                  tys'
 1644 
 1645            StarT
 1646              -> mk_apps
 1647                 (HsTyVar noAnn NotPromoted
 1648                                       (noLocA (getRdrName liftedTypeKindTyCon)))
 1649                 tys'
 1650 
 1651            ConstraintT
 1652              -> mk_apps
 1653                 (HsTyVar noAnn NotPromoted
 1654                                       (noLocA (getRdrName constraintKindTyCon)))
 1655                 tys'
 1656 
 1657            EqualityT
 1658              | Just normals <- m_normals
 1659              , [x',y'] <- normals ->
 1660                    let px = parenthesizeHsType opPrec x'
 1661                        py = parenthesizeHsType opPrec y'
 1662                    in returnLA (HsOpTy noExtField px (noLocA eqTyCon_RDR) py)
 1663                -- The long-term goal is to remove the above case entirely and
 1664                -- subsume it under the case for InfixT. See #15815, comment:6,
 1665                -- for more details.
 1666 
 1667              | otherwise ->
 1668                    mk_apps (HsTyVar noAnn NotPromoted
 1669                             (noLocA eqTyCon_RDR)) tys'
 1670            ImplicitParamT n t
 1671              -> do { n' <- wrapL $ ipName n
 1672                    ; t' <- cvtType t
 1673                    ; returnLA (HsIParamTy noAnn (reLocA n') t')
 1674                    }
 1675 
 1676            _ -> failWith (text "Malformed " <> text ty_str <+> text (show ty))
 1677     }
 1678 
 1679 hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs
 1680 hsTypeToArrow w = case unLoc w of
 1681                      HsTyVar _ _ (L _ (isExact_maybe -> Just n))
 1682                         | n == oneDataConName -> HsLinearArrow (HsPct1 noHsTok noHsUniTok)
 1683                         | n == manyDataConName -> HsUnrestrictedArrow noHsUniTok
 1684                      _ -> HsExplicitMult noHsTok w noHsUniTok
 1685 
 1686 -- ConT/InfixT can contain both data constructor (i.e., promoted) names and
 1687 -- other (i.e, unpromoted) names, as opposed to PromotedT, which can only
 1688 -- contain data constructor names. See #15572/#17394. We use this function to
 1689 -- determine whether to mark a name as promoted/unpromoted when dealing with
 1690 -- ConT/InfixT.
 1691 name_promotedness :: RdrName -> Hs.PromotionFlag
 1692 name_promotedness nm
 1693   | isRdrDataCon nm = IsPromoted
 1694   | otherwise       = NotPromoted
 1695 
 1696 -- | Constructs an application of a type to arguments passed in a list.
 1697 mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
 1698 mk_apps head_ty type_args = do
 1699   head_ty' <- returnLA head_ty
 1700   -- We must parenthesize the function type in case of an explicit
 1701   -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there
 1702   -- _must_ be parentheses around `Maybe :: Type -> Type`.
 1703   let phead_ty :: LHsType GhcPs
 1704       phead_ty = parenthesizeHsType sigPrec head_ty'
 1705 
 1706       go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
 1707       go [] = pure head_ty'
 1708       go (arg:args) =
 1709         case arg of
 1710           HsValArg ty  -> do p_ty <- add_parens ty
 1711                              mk_apps (HsAppTy noExtField phead_ty p_ty) args
 1712           HsTypeArg l ki -> do p_ki <- add_parens ki
 1713                                mk_apps (HsAppKindTy l phead_ty p_ki) args
 1714           HsArgPar _   -> mk_apps (HsParTy noAnn phead_ty) args
 1715 
 1716   go type_args
 1717    where
 1718     -- See Note [Adding parens for splices]
 1719     add_parens lt@(L _ t)
 1720       | hsTypeNeedsParens appPrec t = returnLA (HsParTy noAnn lt)
 1721       | otherwise                   = return lt
 1722 
 1723 wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs
 1724 wrap_tyarg (HsValArg ty)    = HsValArg  $ parenthesizeHsType appPrec ty
 1725 wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki
 1726 wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized
 1727 
 1728 -- ---------------------------------------------------------------------
 1729 -- Note [Adding parens for splices]
 1730 {-
 1731 The hsSyn representation of parsed source explicitly contains all the original
 1732 parens, as written in the source.
 1733 
 1734 When a Template Haskell (TH) splice is evaluated, the original splice is first
 1735 renamed and type checked and then finally converted to core in
 1736 GHC.HsToCore.Quote. This core is then run in the TH engine, and the result
 1737 comes back as a TH AST.
 1738 
 1739 In the process, all parens are stripped out, as they are not needed.
 1740 
 1741 This Convert module then converts the TH AST back to hsSyn AST.
 1742 
 1743 In order to pretty-print this hsSyn AST, parens need to be adde back at certain
 1744 points so that the code is readable with its original meaning.
 1745 
 1746 So scattered through "GHC.ThToHs" are various points where parens are added.
 1747 
 1748 See (among other closed issues) https://gitlab.haskell.org/ghc/ghc/issues/14289
 1749 -}
 1750 -- ---------------------------------------------------------------------
 1751 
 1752 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs])
 1753 split_ty_app ty = go ty []
 1754   where
 1755     go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') }
 1756     go (AppKindT ty ki) as' = do { ki' <- cvtKind ki
 1757                                  ; go ty (HsTypeArg noSrcSpan ki':as') }
 1758     go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') }
 1759     go f as           = return (f,as)
 1760 
 1761 cvtTyLit :: TH.TyLit -> HsTyLit
 1762 cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i
 1763 cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)
 1764 cvtTyLit (TH.CharTyLit c) = HsCharTy NoSourceText c
 1765 
 1766 {- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator
 1767 application @x `op` y@. The produced tree of infix types will be right-biased,
 1768 provided @y@ is.
 1769 
 1770 See the @cvtOpApp@ documentation for how this function works.
 1771 -}
 1772 cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)
 1773 cvtOpAppT (UInfixT x op2 y) op1 z
 1774   = do { l <- cvtOpAppT y op1 z
 1775        ; cvtOpAppT x op2 l }
 1776 cvtOpAppT x op y
 1777   = do { op' <- tconNameN op
 1778        ; x' <- cvtType x
 1779        ; returnLA (mkHsOpTy x' op' y) }
 1780 
 1781 cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
 1782 cvtKind = cvtTypeKind "kind"
 1783 
 1784 cvtSigKind :: TH.Kind -> CvtM (LHsSigType GhcPs)
 1785 cvtSigKind = cvtSigTypeKind "kind"
 1786 
 1787 -- | Convert Maybe Kind to a type family result signature. Used with data
 1788 -- families where naming of the result is not possible (thus only kind or no
 1789 -- signature is possible).
 1790 cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind
 1791                               -> CvtM (LFamilyResultSig GhcPs)
 1792 cvtMaybeKindToFamilyResultSig Nothing   = returnLA (Hs.NoSig noExtField)
 1793 cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki
 1794                                              ; returnLA (Hs.KindSig noExtField ki') }
 1795 
 1796 -- | Convert type family result signature. Used with both open and closed type
 1797 -- families.
 1798 cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)
 1799 cvtFamilyResultSig TH.NoSig           = returnLA (Hs.NoSig noExtField)
 1800 cvtFamilyResultSig (TH.KindSig ki)    = do { ki' <- cvtKind ki
 1801                                            ; returnLA (Hs.KindSig noExtField  ki') }
 1802 cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr
 1803                                            ; returnLA (Hs.TyVarSig noExtField tv) }
 1804 
 1805 -- | Convert injectivity annotation of a type family.
 1806 cvtInjectivityAnnotation :: TH.InjectivityAnn
 1807                          -> CvtM (Hs.LInjectivityAnn GhcPs)
 1808 cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
 1809   = do { annLHS' <- tNameN annLHS
 1810        ; annRHS' <- mapM tNameN annRHS
 1811        ; returnLA (Hs.InjectivityAnn noAnn annLHS' annRHS') }
 1812 
 1813 cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs)
 1814 -- pattern synonym types are of peculiar shapes, which is why we treat
 1815 -- them separately from regular types;
 1816 -- see Note [Pattern synonym type signatures and Template Haskell]
 1817 cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
 1818   | null exis, null provs = cvtSigType (ForallT univs reqs ty)
 1819   | null univs, null reqs = do { l'  <- getL
 1820                                ; let l = noAnnSrcSpan l'
 1821                                ; ty' <- cvtType (ForallT exis provs ty)
 1822                                ; return $ L l $ mkHsImplicitSigType
 1823                                         $ L l (HsQualTy { hst_ctxt = noLocA []
 1824                                                         , hst_xqual = noExtField
 1825                                                         , hst_body = ty' }) }
 1826   | null reqs             = do { l'      <- getL
 1827                                ; let l'' = noAnnSrcSpan l'
 1828                                ; univs' <- cvtTvs univs
 1829                                ; ty'    <- cvtType (ForallT exis provs ty)
 1830                                ; let forTy = mkHsExplicitSigType noAnn univs' $ L l'' cxtTy
 1831                                      cxtTy = HsQualTy { hst_ctxt = noLocA []
 1832                                                       , hst_xqual = noExtField
 1833                                                       , hst_body = ty' }
 1834                                ; return $ L (noAnnSrcSpan l') forTy }
 1835   | otherwise             = cvtSigType (ForallT univs reqs (ForallT exis provs ty))
 1836 cvtPatSynSigTy ty         = cvtSigType ty
 1837 
 1838 -----------------------------------------------------------
 1839 cvtFixity :: TH.Fixity -> Hs.Fixity
 1840 cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir)
 1841    where
 1842      cvt_dir TH.InfixL = Hs.InfixL
 1843      cvt_dir TH.InfixR = Hs.InfixR
 1844      cvt_dir TH.InfixN = Hs.InfixN
 1845 
 1846 -----------------------------------------------------------
 1847 
 1848 
 1849 -----------------------------------------------------------
 1850 -- some useful things
 1851 
 1852 overloadedLit :: Lit -> Bool
 1853 -- True for literals that Haskell treats as overloaded
 1854 overloadedLit (IntegerL  _) = True
 1855 overloadedLit (RationalL _) = True
 1856 overloadedLit _             = False
 1857 
 1858 -- Checks that are performed when converting unboxed sum expressions and
 1859 -- patterns alike.
 1860 unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()
 1861 unboxedSumChecks alt arity
 1862     | alt > arity
 1863     = failWith $ text "Sum alternative"    <+> text (show alt)
 1864              <+> text "exceeds its arity," <+> text (show arity)
 1865     | alt <= 0
 1866     = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt)
 1867                       , nest 2 $ text "Sum alternatives must start from 1" ]
 1868     | arity < 2
 1869     = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity)
 1870                       , nest 2 $ text "Sums must have an arity of at least 2" ]
 1871     | otherwise
 1872     = return ()
 1873 
 1874 -- | If passed an empty list of 'LHsTyVarBndr's, this simply returns the
 1875 -- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'
 1876 -- using the provided 'LHsQTyVars' and 'LHsType'.
 1877 mkHsForAllTy :: SrcSpanAnnA
 1878              -- ^ The location of the returned 'LHsType' if it needs an
 1879              --   explicit forall
 1880              -> HsForAllTelescope GhcPs
 1881              -- ^ The converted type variable binders
 1882              -> LHsType GhcPs
 1883              -- ^ The converted rho type
 1884              -> LHsType GhcPs
 1885              -- ^ The complete type, quantified with a forall if necessary
 1886 mkHsForAllTy loc tele rho_ty
 1887   | no_tvs    = rho_ty
 1888   | otherwise = L loc $ HsForAllTy { hst_tele = tele
 1889                                    , hst_xforall = noExtField
 1890                                    , hst_body = rho_ty }
 1891   where
 1892     no_tvs = case tele of
 1893       HsForAllVis   { hsf_vis_bndrs   = bndrs } -> null bndrs
 1894       HsForAllInvis { hsf_invis_bndrs = bndrs } -> null bndrs
 1895 
 1896 -- | If passed an empty 'TH.Cxt', this simply returns the third argument
 1897 -- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided
 1898 -- 'LHsContext' and 'LHsType'.
 1899 
 1900 -- It's important that we don't build an HsQualTy if the context is empty,
 1901 -- as the pretty-printer for HsType _always_ prints contexts, even if
 1902 -- they're empty. See #13183.
 1903 mkHsQualTy :: TH.Cxt
 1904            -- ^ The original Template Haskell context
 1905            -> SrcSpanAnnA
 1906            -- ^ The location of the returned 'LHsType' if it needs an
 1907            --   explicit context
 1908            -> LHsContext GhcPs
 1909            -- ^ The converted context
 1910            -> LHsType GhcPs
 1911            -- ^ The converted tau type
 1912            -> LHsType GhcPs
 1913            -- ^ The complete type, qualified with a context if necessary
 1914 mkHsQualTy ctxt loc ctxt' ty
 1915   | null ctxt = ty
 1916   | otherwise = L loc $ HsQualTy { hst_xqual = noExtField
 1917                                  , hst_ctxt  = ctxt'
 1918                                  , hst_body  = ty }
 1919 
 1920 -- | @'mkHsContextMaybe' lc@ returns 'Nothing' if @lc@ is empty and @'Just' lc@
 1921 -- otherwise.
 1922 --
 1923 -- This is much like 'mkHsQualTy', except that it returns a
 1924 -- @'Maybe' ('LHsContext' 'GhcPs')@. This is used specifically for constructing
 1925 -- superclasses, datatype contexts (#20011), and contexts in GADT constructor
 1926 -- types (#20590). We wish to avoid using @'Just' []@ in the case of an empty
 1927 -- contexts, as the pretty-printer always prints 'Just' contexts, even if
 1928 -- they're empty.
 1929 mkHsContextMaybe :: LHsContext GhcPs -> Maybe (LHsContext GhcPs)
 1930 mkHsContextMaybe lctxt@(L _ ctxt)
 1931   | null ctxt = Nothing
 1932   | otherwise = Just lctxt
 1933 
 1934 mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs
 1935 mkHsOuterFamEqnTyVarBndrs = maybe mkHsOuterImplicit (mkHsOuterExplicit noAnn)
 1936 
 1937 --------------------------------------------------------------------
 1938 --      Turning Name back into RdrName
 1939 --------------------------------------------------------------------
 1940 
 1941 -- variable names
 1942 vNameN, cNameN, vcNameN, tNameN, tconNameN :: TH.Name -> CvtM (LocatedN RdrName)
 1943 vNameL                                     :: TH.Name -> CvtM (LocatedA RdrName)
 1944 vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName
 1945 
 1946 -- Variable names
 1947 vNameN n = wrapLN (vName n)
 1948 vNameL n = wrapLA (vName n)
 1949 vName n = cvtName OccName.varName n
 1950 
 1951 -- Constructor function names; this is Haskell source, hence srcDataName
 1952 cNameN n = wrapLN (cName n)
 1953 cName n = cvtName OccName.dataName n
 1954 
 1955 -- Variable *or* constructor names; check by looking at the first char
 1956 vcNameN n = wrapLN (vcName n)
 1957 vcName n = if isVarName n then vName n else cName n
 1958 
 1959 -- Type variable names
 1960 tNameN n = wrapLN (tName n)
 1961 tName n = cvtName OccName.tvName n
 1962 
 1963 -- Type Constructor names
 1964 tconNameN n = wrapLN (tconName n)
 1965 tconName n = cvtName OccName.tcClsName n
 1966 
 1967 ipName :: String -> CvtM HsIPName
 1968 ipName n
 1969   = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n))
 1970        ; return (HsIPName (fsLit n)) }
 1971 
 1972 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
 1973 cvtName ctxt_ns (TH.Name occ flavour)
 1974   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
 1975   | otherwise
 1976   = do { loc <- getL
 1977        ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour
 1978        ; force rdr_name
 1979        ; return rdr_name }
 1980   where
 1981     occ_str = TH.occString occ
 1982 
 1983 okOcc :: OccName.NameSpace -> String -> Bool
 1984 okOcc ns str
 1985   | OccName.isVarNameSpace ns     = okVarOcc str
 1986   | OccName.isDataConNameSpace ns = okConOcc str
 1987   | otherwise                     = okTcOcc  str
 1988 
 1989 -- Determine the name space of a name in a type
 1990 --
 1991 isVarName :: TH.Name -> Bool
 1992 isVarName (TH.Name occ _)
 1993   = case TH.occString occ of
 1994       ""    -> False
 1995       (c:_) -> startsVarId c || startsVarSym c
 1996 
 1997 badOcc :: OccName.NameSpace -> String -> SDoc
 1998 badOcc ctxt_ns occ
 1999   = text "Illegal" <+> pprNameSpace ctxt_ns
 2000         <+> text "name:" <+> quotes (text occ)
 2001 
 2002 thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
 2003 -- This turns a TH Name into a RdrName; used for both binders and occurrences
 2004 -- See Note [Binders in Template Haskell]
 2005 -- The passed-in name space tells what the context is expecting;
 2006 --      use it unless the TH name knows what name-space it comes
 2007 --      from, in which case use the latter
 2008 --
 2009 -- We pass in a SrcSpan (gotten from the monad) because this function
 2010 -- is used for *binders* and if we make an Exact Name we want it
 2011 -- to have a binding site inside it.  (cf #5434)
 2012 --
 2013 -- ToDo: we may generate silly RdrNames, by passing a name space
 2014 --       that doesn't match the string, like VarName ":+",
 2015 --       which will give confusing error messages later
 2016 --
 2017 -- The strict applications ensure that any buried exceptions get forced
 2018 thRdrName loc ctxt_ns th_occ th_name
 2019   = case th_name of
 2020      TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod
 2021      TH.NameQ mod  -> (mkRdrQual  $! mk_mod mod) $! occ
 2022      TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq (fromInteger uniq)) $! occ) loc)
 2023      TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq (fromInteger uniq)) $! occ) loc)
 2024      TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name
 2025               | otherwise                           -> mkRdrUnqual $! occ
 2026               -- We check for built-in syntax here, because the TH
 2027               -- user might have written a (NameS "(,,)"), for example
 2028   where
 2029     occ :: OccName.OccName
 2030     occ = mk_occ ctxt_ns th_occ
 2031 
 2032 -- Return an unqualified exact RdrName if we're dealing with built-in syntax.
 2033 -- See #13776.
 2034 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
 2035 thOrigRdrName occ th_ns pkg mod =
 2036   let occ' = mk_occ (mk_ghc_ns th_ns) occ
 2037   in case isBuiltInOcc_maybe occ' of
 2038        Just name -> nameRdrName name
 2039        Nothing   -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ'
 2040 
 2041 thRdrNameGuesses :: TH.Name -> [RdrName]
 2042 thRdrNameGuesses (TH.Name occ flavour)
 2043   -- This special case for NameG ensures that we don't generate duplicates in the output list
 2044   | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]
 2045   | otherwise                         = [ thRdrName noSrcSpan gns occ_str flavour
 2046                                         | gns <- guessed_nss]
 2047   where
 2048     -- guessed_ns are the name spaces guessed from looking at the TH name
 2049     guessed_nss
 2050       | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
 2051       | otherwise                       = [OccName.varName, OccName.tvName]
 2052     occ_str = TH.occString occ
 2053 
 2054 -- The packing and unpacking is rather turgid :-(
 2055 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
 2056 mk_occ ns occ = OccName.mkOccName ns occ
 2057 
 2058 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
 2059 mk_ghc_ns TH.DataName  = OccName.dataName
 2060 mk_ghc_ns TH.TcClsName = OccName.tcClsName
 2061 mk_ghc_ns TH.VarName   = OccName.varName
 2062 
 2063 mk_mod :: TH.ModName -> ModuleName
 2064 mk_mod mod = mkModuleName (TH.modString mod)
 2065 
 2066 mk_pkg :: TH.PkgName -> Unit
 2067 mk_pkg pkg = stringToUnit (TH.pkgString pkg)
 2068 
 2069 mk_uniq :: Int -> Unique
 2070 mk_uniq u = mkUniqueGrimily u
 2071 
 2072 {-
 2073 Note [Binders in Template Haskell]
 2074 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 2075 Consider this TH term construction:
 2076   do { x1 <- TH.newName "x"   -- newName :: String -> Q TH.Name
 2077      ; x2 <- TH.newName "x"   -- Builds a NameU
 2078      ; x3 <- TH.newName "x"
 2079 
 2080      ; let x = mkName "x"     -- mkName :: String -> TH.Name
 2081                               -- Builds a NameS
 2082 
 2083      ; return (LamE (..pattern [x1,x2]..) $
 2084                LamE (VarPat x3) $
 2085                ..tuple (x1,x2,x3,x)) }
 2086 
 2087 It represents the term   \[x1,x2]. \x3. (x1,x2,x3,x)
 2088 
 2089 a) We don't want to complain about "x" being bound twice in
 2090    the pattern [x1,x2]
 2091 b) We don't want x3 to shadow the x1,x2
 2092 c) We *do* want 'x' (dynamically bound with mkName) to bind
 2093    to the innermost binding of "x", namely x3.
 2094 d) When pretty printing, we want to print a unique with x1,x2
 2095    etc, else they'll all print as "x" which isn't very helpful
 2096 
 2097 When we convert all this to HsSyn, the TH.Names are converted with
 2098 thRdrName.  To achieve (b) we want the binders to be Exact RdrNames.
 2099 Achieving (a) is a bit awkward, because
 2100    - We must check for duplicate and shadowed names on Names,
 2101      not RdrNames, *after* renaming.
 2102      See Note [Collect binders only after renaming] in GHC.Hs.Utils
 2103 
 2104    - But to achieve (a) we must distinguish between the Exact
 2105      RdrNames arising from TH and the Unqual RdrNames that would
 2106      come from a user writing \[x,x] -> blah
 2107 
 2108 So in Convert.thRdrName we translate
 2109    TH Name                          RdrName
 2110    --------------------------------------------------------
 2111    NameU (arising from newName) --> Exact (Name{ System })
 2112    NameS (arising from mkName)  --> Unqual
 2113 
 2114 Notice that the NameUs generate *System* Names.  Then, when
 2115 figuring out shadowing and duplicates, we can filter out
 2116 System Names.
 2117 
 2118 This use of System Names fits with other uses of System Names, eg for
 2119 temporary variables "a". Since there are lots of things called "a" we
 2120 usually want to print the name with the unique, and that is indeed
 2121 the way System Names are printed.
 2122 
 2123 There's a small complication of course; see Note [Looking up Exact
 2124 RdrNames] in GHC.Rename.Env.
 2125 -}
 2126 
 2127 {-
 2128 Note [Pattern synonym type signatures and Template Haskell]
 2129 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 2130 
 2131 In general, the type signature of a pattern synonym
 2132 
 2133   pattern P x1 x2 .. xn = <some-pattern>
 2134 
 2135 is of the form
 2136 
 2137    forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
 2138 
 2139 with the following parts:
 2140 
 2141    1) the (possibly empty lists of) universally quantified type
 2142       variables `univs` and required constraints `reqs` on them.
 2143    2) the (possibly empty lists of) existentially quantified type
 2144       variables `exis` and the provided constraints `provs` on them.
 2145    3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,
 2146       x2, .., xn, respectively
 2147    4) the type `t` of <some-pattern>, mentioning only universals from `univs`.
 2148 
 2149 Due to the two forall quantifiers and constraint contexts (either of
 2150 which might be empty), pattern synonym type signatures are treated
 2151 specially in `GHC.HsToCore.Quote`, `GHC.ThToHs`, and
 2152 `GHC.Tc.Gen.Splice`:
 2153 
 2154    (a) When desugaring a pattern synonym from HsSyn to TH.Dec in
 2155        `GHC.HsToCore.Quote`, we represent its *full* type signature in TH, i.e.:
 2156 
 2157            ForallT univs reqs (ForallT exis provs ty)
 2158               (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
 2159 
 2160    (b) When converting pattern synonyms from TH.Dec to HsSyn in
 2161        `GHC.ThToHs`, we convert their TH type signatures back to an
 2162        appropriate Haskell pattern synonym type of the form
 2163 
 2164          forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
 2165 
 2166        where initial empty `univs` type variables or an empty `reqs`
 2167        constraint context are represented *explicitly* as `() =>`.
 2168 
 2169    (c) When reifying a pattern synonym in `GHC.Tc.Gen.Splice`, we always
 2170        return its *full* type, i.e.:
 2171 
 2172            ForallT univs reqs (ForallT exis provs ty)
 2173               (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
 2174 
 2175 The key point is to always represent a pattern synonym's *full* type
 2176 in cases (a) and (c) to make it clear which of the two forall
 2177 quantifiers and/or constraint contexts are specified, and which are
 2178 not. See GHC's user's guide on pattern synonyms for more information
 2179 about pattern synonym type signatures.
 2180 
 2181 -}