Convert.hs

{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998


This module converts Template Haskell syntax into HsSyn
-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
                convertToHsType,
                thRdrNameGuesses ) where

import GhcPrelude

import HsSyn as Hs
import PrelNames
import RdrName
import qualified Name
import Module
import RdrHsSyn
import qualified OccName
import OccName
import SrcLoc
import Type
import qualified Coercion ( Role(..) )
import TysWiredIn
import BasicTypes as Hs
import ForeignCall
import Unique
import ErrUtils
import Bag
import Lexeme
import Util
import FastString
import Outputable
import MonadUtils ( foldrM )

import qualified Data.ByteString as BS
import Control.Monad( unless, liftM, ap, (<=<) )

import Data.Maybe( catMaybes, isNothing )
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH

-------------------------------------------------------------------
--              The external interface

convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]
convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))
  where
    cvt_dec d = wrapMsg "declaration" d (cvtDec d)

convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)
convertToHsExpr loc e
  = initCvt loc $ wrapMsg "expression" e $ cvtl e

convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)
convertToPat loc p
  = initCvt loc $ wrapMsg "pattern" p $ cvtPat p

convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)
convertToHsType loc t
  = initCvt loc $ wrapMsg "type" t $ cvtType t

-------------------------------------------------------------------
newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
        -- Push down the source location;
        -- Can fail, with a single error message

-- NB: If the conversion succeeds with (Right x), there should
--     be no exception values hiding in x
-- Reason: so a (head []) in TH code doesn't subsequently
--         make GHC crash when it tries to walk the generated tree

-- Use the loc everywhere, for lack of anything better
-- In particular, we want it on binding locations, so that variables bound in
-- the spliced-in declarations get a location that at least relates to the splice point

instance Functor CvtM where
    fmap = liftM

instance Applicative CvtM where
    pure x = CvtM $ \loc -> Right (loc,x)
    (<*>) = ap

instance Monad CvtM where
  (CvtM m) >>= k = CvtM $ \loc -> case m loc of
                                  Left err -> Left err
                                  Right (loc',v) -> unCvtM (k v) loc'

initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
initCvt loc (CvtM m) = fmap snd (m loc)

force :: a -> CvtM ()
force a = a `seq` return ()

failWith :: MsgDoc -> CvtM a
failWith m = CvtM (\_ -> Left m)

getL :: CvtM SrcSpan
getL = CvtM (\loc -> Right (loc,loc))

setL :: SrcSpan -> CvtM ()
setL loc = CvtM (\_ -> Right (loc, ()))

returnL :: a -> CvtM (Located a)
returnL x = CvtM (\loc -> Right (loc, L loc x))

returnJustL :: a -> CvtM (Maybe (Located a))
returnJustL = fmap Just . returnL

wrapParL :: (Located a -> a) -> a -> CvtM a
wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (L loc x)))

wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
-- E.g  wrapMsg "declaration" dec thing
wrapMsg what item (CvtM m)
  = CvtM (\loc -> case m loc of
                     Left err -> Left (err $$ getPprStyle msg)
                     Right v  -> Right v)
  where
        -- Show the item in pretty syntax normally,
        -- but with all its constructors if you say -dppr-debug
    msg sty = hang (text "When splicing a TH" <+> text what <> colon)
                 2 (if debugStyle sty
                    then text (show item)
                    else text (pprint item))

wrapL :: CvtM a -> CvtM (Located a)
wrapL (CvtM m) = CvtM (\loc -> case m loc of
                               Left err -> Left err
                               Right (loc',v) -> Right (loc',L loc v))

-------------------------------------------------------------------
cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
cvtDecs = fmap catMaybes . mapM cvtDec

cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))
cvtDec (TH.ValD pat body ds)
  | TH.VarP s <- pat
  = do  { s' <- vNameL s
        ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
        ; returnJustL $ Hs.ValD noExt $ mkFunBind s' [cl'] }

  | otherwise
  = do  { pat' <- cvtPat pat
        ; body' <- cvtGuard body
        ; ds' <- cvtLocalDecs (text "a where clause") ds
        ; returnJustL $ Hs.ValD noExt $
          PatBind { pat_lhs = pat', pat_rhs = GRHSs noExt body' (noLoc ds')
                  , pat_ext = noExt
                  , pat_ticks = ([],[]) } }

cvtDec (TH.FunD nm cls)
  | null cls
  = failWith (text "Function binding for"
                 <+> quotes (text (TH.pprint nm))
                 <+> text "has no equations")
  | otherwise
  = do  { nm' <- vNameL nm
        ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
        ; returnJustL $ Hs.ValD noExt $ mkFunBind nm' cls' }

cvtDec (TH.SigD nm typ)
  = do  { nm' <- vNameL nm
        ; ty' <- cvtType typ
        ; returnJustL $ Hs.SigD noExt
                                    (TypeSig noExt [nm'] (mkLHsSigWcType ty')) }

cvtDec (TH.InfixD fx nm)
  -- Fixity signatures are allowed for variables, constructors, and types
  -- the renamer automatically looks for types during renaming, even when
  -- the RdrName says it's a variable or a constructor. So, just assume
  -- it's a variable or constructor and proceed.
  = do { nm' <- vcNameL nm
       ; returnJustL (Hs.SigD noExt (FixSig noExt
                                      (FixitySig noExt [nm'] (cvtFixity fx)))) }

cvtDec (PragmaD prag)
  = cvtPragmaD prag

cvtDec (TySynD tc tvs rhs)
  = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
        ; rhs' <- cvtType rhs
        ; returnJustL $ TyClD noExt $
          SynDecl { tcdSExt = noExt, tcdLName = tc', tcdTyVars = tvs'
                  , tcdFixity = Prefix
                  , tcdRhs = rhs' } }

cvtDec (DataD ctxt tc tvs ksig constrs derivs)
  = do  { let isGadtCon (GadtC    _ _ _) = True
              isGadtCon (RecGadtC _ _ _) = True
              isGadtCon (ForallC  _ _ c) = isGadtCon c
              isGadtCon _                = False
              isGadtDecl  = all isGadtCon constrs
              isH98Decl   = all (not . isGadtCon) constrs
        ; unless (isGadtDecl || isH98Decl)
                 (failWith (text "Cannot mix GADT constructors with Haskell 98"
                        <+> text "constructors"))
        ; unless (isNothing ksig || isGadtDecl)
                 (failWith (text "Kind signatures are only allowed on GADTs"))
        ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
        ; ksig' <- cvtKind `traverse` ksig
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
        ; let defn = HsDataDefn { dd_ext = noExt
                                , dd_ND = DataType, dd_cType = Nothing
                                , dd_ctxt = ctxt'
                                , dd_kindSig = ksig'
                                , dd_cons = cons', dd_derivs = derivs' }
        ; returnJustL $ TyClD noExt (DataDecl
                                        { tcdDExt = noExt
                                        , tcdLName = tc', tcdTyVars = tvs'
                                        , tcdFixity = Prefix
                                        , tcdDataDefn = defn }) }

cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
        ; ksig' <- cvtKind `traverse` ksig
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
        ; let defn = HsDataDefn { dd_ext = noExt
                                , dd_ND = NewType, dd_cType = Nothing
                                , dd_ctxt = ctxt'
                                , dd_kindSig = ksig'
                                , dd_cons = [con']
                                , dd_derivs = derivs' }
        ; returnJustL $ TyClD noExt (DataDecl
                                    { tcdDExt = noExt
                                    , tcdLName = tc', tcdTyVars = tvs'
                                    , tcdFixity = Prefix
                                    , tcdDataDefn = defn }) }

cvtDec (ClassD ctxt cl tvs fds decs)
  = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
        ; fds'  <- mapM cvt_fundep fds
        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (text "a class declaration") decs
        ; unless (null adts')
            (failWith $ (text "Default data instance declarations"
                     <+> text "are not allowed:")
                   $$ (Outputable.ppr adts'))
        ; at_defs <- mapM cvt_at_def ats'
        ; returnJustL $ TyClD noExt $
          ClassDecl { tcdCExt = noExt
                    , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
                    , tcdFixity = Prefix
                    , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
                    , tcdMeths = binds'
                    , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] }
                              -- no docs in TH ^^
        }
  where
    cvt_at_def :: LTyFamInstDecl GhcPs -> CvtM (LTyFamDefltEqn GhcPs)
    -- Very similar to what happens in RdrHsSyn.mkClassDecl
    cvt_at_def decl = case RdrHsSyn.mkATDefault decl of
                        Right def     -> return def
                        Left (_, msg) -> failWith msg

cvtDec (InstanceD o ctxt ty decs)
  = do  { let doc = text "an instance declaration"
        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
        ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
        ; ctxt' <- cvtContext ctxt
        ; L loc ty' <- cvtType ty
        ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty'
        ; returnJustL $ InstD noExt $ ClsInstD noExt $
          ClsInstDecl { cid_ext = noExt, cid_poly_ty = mkLHsSigType inst_ty'
                      , cid_binds = binds'
                      , cid_sigs = Hs.mkClassOpSigs sigs'
                      , cid_tyfam_insts = ats', cid_datafam_insts = adts'
                      , cid_overlap_mode = fmap (L loc . overlap) o } }
  where
  overlap pragma =
    case pragma of
      TH.Overlaps      -> Hs.Overlaps     (SourceText "OVERLAPS")
      TH.Overlappable  -> Hs.Overlappable (SourceText "OVERLAPPABLE")
      TH.Overlapping   -> Hs.Overlapping  (SourceText "OVERLAPPING")
      TH.Incoherent    -> Hs.Incoherent   (SourceText "INCOHERENT")




cvtDec (ForeignD ford)
  = do { ford' <- cvtForD ford
       ; returnJustL $ ForD noExt ford' }

cvtDec (DataFamilyD tc tvs kind)
  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
       ; result <- cvtMaybeKindToFamilyResultSig kind
       ; returnJustL $ TyClD noExt $ FamDecl noExt $
         FamilyDecl noExt DataFamily tc' tvs' Prefix result Nothing }

cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
  = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
       ; ksig' <- cvtKind `traverse` ksig
       ; cons' <- mapM cvtConstr constrs
       ; derivs' <- cvtDerivs derivs
       ; let defn = HsDataDefn { dd_ext = noExt
                               , dd_ND = DataType, dd_cType = Nothing
                               , dd_ctxt = ctxt'
                               , dd_kindSig = ksig'
                               , dd_cons = cons', dd_derivs = derivs' }

       ; returnJustL $ InstD noExt $ DataFamInstD
           { dfid_ext = noExt
           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
                           FamEqn { feqn_ext = noExt
                                  , feqn_tycon = tc', feqn_pats = typats'
                                  , feqn_rhs = defn
                                  , feqn_fixity = Prefix } }}}

cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
  = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
       ; ksig' <- cvtKind `traverse` ksig
       ; con' <- cvtConstr constr
       ; derivs' <- cvtDerivs derivs
       ; let defn = HsDataDefn { dd_ext = noExt
                               , dd_ND = NewType, dd_cType = Nothing
                               , dd_ctxt = ctxt'
                               , dd_kindSig = ksig'
                               , dd_cons = [con'], dd_derivs = derivs' }
       ; returnJustL $ InstD noExt $ DataFamInstD
           { dfid_ext = noExt
           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
                           FamEqn { feqn_ext = noExt
                                  , feqn_tycon = tc', feqn_pats = typats'
                                  , feqn_rhs = defn
                                  , feqn_fixity = Prefix } }}}

cvtDec (TySynInstD tc eqn)
  = do  { tc' <- tconNameL tc
        ; L _ eqn' <- cvtTySynEqn tc' eqn
        ; returnJustL $ InstD noExt $ TyFamInstD
            { tfid_ext = noExt
            , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }

cvtDec (OpenTypeFamilyD head)
  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
       ; returnJustL $ TyClD noExt $ FamDecl noExt $
         FamilyDecl noExt OpenTypeFamily tc' tyvars' Prefix result' injectivity'
       }

cvtDec (ClosedTypeFamilyD head eqns)
  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
       ; eqns' <- mapM (cvtTySynEqn tc') eqns
       ; returnJustL $ TyClD noExt $ FamDecl noExt $
         FamilyDecl noExt (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix
                           result' injectivity' }

cvtDec (TH.RoleAnnotD tc roles)
  = do { tc' <- tconNameL tc
       ; let roles' = map (noLoc . cvtRole) roles
       ; returnJustL $ Hs.RoleAnnotD noExt (RoleAnnotDecl noExt tc' roles') }

cvtDec (TH.StandaloneDerivD ds cxt ty)
  = do { cxt' <- cvtContext cxt
       ; ds'  <- traverse cvtDerivStrategy ds
       ; L loc ty'  <- cvtType ty
       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
       ; returnJustL $ DerivD noExt $
         DerivDecl { deriv_ext =noExt
                   , deriv_strategy = ds'
                   , deriv_type = mkLHsSigWcType inst_ty'
                   , deriv_overlap_mode = Nothing } }

cvtDec (TH.DefaultSigD nm typ)
  = do { nm' <- vNameL nm
       ; ty' <- cvtType typ
       ; returnJustL $ Hs.SigD noExt
                     $ ClassOpSig noExt True [nm'] (mkLHsSigType ty')}

cvtDec (TH.PatSynD nm args dir pat)
  = do { nm'   <- cNameL nm
       ; args' <- cvtArgs args
       ; dir'  <- cvtDir nm' dir
       ; pat'  <- cvtPat pat
       ; returnJustL $ Hs.ValD noExt $ PatSynBind noExt $
           PSB noExt nm' args' pat' dir' }
  where
    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args
    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2
    cvtArgs (TH.RecordPatSyn sels)
      = do { sels' <- mapM vNameL sels
           ; vars' <- mapM (vNameL . mkNameS . nameBase) sels
           ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }

    cvtDir _ Unidir          = return Unidirectional
    cvtDir _ ImplBidir       = return ImplicitBidirectional
    cvtDir n (ExplBidir cls) =
      do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
         ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }

cvtDec (TH.PatSynSigD nm ty)
  = do { nm' <- cNameL nm
       ; ty' <- cvtPatSynSigTy ty
       ; returnJustL $ Hs.SigD noExt $ PatSynSig noExt [nm'] (mkLHsSigType ty')}

----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn tc (TySynEqn lhs rhs)
  = do  { lhs' <- mapM (wrap_apps <=< cvtType) lhs
        ; rhs' <- cvtType rhs
        ; returnL $ mkHsImplicitBndrs
                  $ FamEqn { feqn_ext    = noExt
                           , feqn_tycon  = tc
                           , feqn_pats   = lhs'
                           , feqn_fixity = Prefix
                           , feqn_rhs    = rhs' } }

----------------
cvt_ci_decs :: MsgDoc -> [TH.Dec]
            -> CvtM (LHsBinds GhcPs,
                     [LSig GhcPs],
                     [LFamilyDecl GhcPs],
                     [LTyFamInstDecl GhcPs],
                     [LDataFamInstDecl GhcPs])
-- Convert the declarations inside a class or instance decl
-- ie signatures, bindings, and associated types
cvt_ci_decs doc decs
  = do  { decs' <- cvtDecs decs
        ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'
        ; let (adts', no_ats')       = partitionWith is_datafam_inst bind_sig_decs'
        ; let (sigs', prob_binds')   = partitionWith is_sig no_ats'
        ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'
        ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'
        ; unless (null bads) (failWith (mkBadDecMsg doc bads))
          --We use FromSource as the origin of the bind
          -- because the TH declaration is user-written
        ; return (listToBag binds', sigs', fams', ats', adts') }

----------------
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
             -> CvtM ( LHsContext GhcPs
                     , Located RdrName
                     , LHsQTyVars GhcPs)
cvt_tycl_hdr cxt tc tvs
  = do { cxt' <- cvtContext cxt
       ; tc'  <- tconNameL tc
       ; tvs' <- cvtTvs tvs
       ; return (cxt', tc', tvs')
       }

cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
               -> CvtM ( LHsContext GhcPs
                       , Located RdrName
                       , HsTyPats GhcPs)
cvt_tyinst_hdr cxt tc tys
  = do { cxt' <- cvtContext cxt
       ; tc'  <- tconNameL tc
       ; tys' <- mapM (wrap_apps <=< cvtType) tys
       ; return (cxt', tc', tys') }

----------------
cvt_tyfam_head :: TypeFamilyHead
               -> CvtM ( Located RdrName
                       , LHsQTyVars GhcPs
                       , Hs.LFamilyResultSig GhcPs
                       , Maybe (Hs.LInjectivityAnn GhcPs))

cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)
  = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars
       ; result' <- cvtFamilyResultSig result
       ; injectivity' <- traverse cvtInjectivityAnnotation injectivity
       ; return (tc', tyvars', result', injectivity') }

-------------------------------------------------------------------
--              Partitioning declarations
-------------------------------------------------------------------

is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
is_fam_decl (L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (L loc d)
is_fam_decl decl = Right decl

is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
is_tyfam_inst (L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
  = Left (L loc d)
is_tyfam_inst decl
  = Right decl

is_datafam_inst :: LHsDecl GhcPs
                -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
is_datafam_inst (L loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))
  = Left (L loc d)
is_datafam_inst decl
  = Right decl

is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig)
is_sig decl                    = Right decl

is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind)
is_bind decl                     = Right decl

mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
mkBadDecMsg doc bads
  = sep [ text "Illegal declaration(s) in" <+> doc <> colon
        , nest 2 (vcat (map Outputable.ppr bads)) ]

---------------------------------------------------
--      Data types
---------------------------------------------------

cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)

cvtConstr (NormalC c strtys)
  = do  { c'   <- cNameL c
        ; tys' <- mapM cvt_arg strtys
        ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') }

cvtConstr (RecC c varstrtys)
  = do  { c'    <- cNameL c
        ; args' <- mapM cvt_id_arg varstrtys
        ; returnL $ mkConDeclH98 c' Nothing Nothing
                                   (RecCon (noLoc args')) }

cvtConstr (InfixC st1 c st2)
  = do  { c'   <- cNameL c
        ; st1' <- cvt_arg st1
        ; st2' <- cvt_arg st2
        ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') }

cvtConstr (ForallC tvs ctxt con)
  = do  { tvs'      <- cvtTvs tvs
        ; ctxt'     <- cvtContext ctxt
        ; L _ con'  <- cvtConstr con
        ; returnL $ add_forall tvs' ctxt' con' }
  where
    add_cxt lcxt         Nothing           = Just lcxt
    add_cxt (L loc cxt1) (Just (L _ cxt2)) = Just (L loc (cxt1 ++ cxt2))

    add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
      = con { con_forall = noLoc $ not (null all_tvs)
            , con_qvars  = mkHsQTvs all_tvs
            , con_mb_cxt = add_cxt cxt' cxt }
      where
        all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars

    add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })
      = con { con_forall = noLoc $ not (null all_tvs)
            , con_ex_tvs = all_tvs
            , con_mb_cxt = add_cxt cxt' cxt }
      where
        all_tvs = hsQTvExplicit tvs' ++ ex_tvs

    add_forall _ _ (XConDecl _) = panic "cvtConstr"

cvtConstr (GadtC c strtys ty)
  = do  { c'      <- mapM cNameL c
        ; args    <- mapM cvt_arg strtys
        ; L _ ty' <- cvtType ty
        ; c_ty    <- mk_arr_apps args ty'
        ; returnL $ fst $ mkGadtDecl c' c_ty}

cvtConstr (RecGadtC c varstrtys ty)
  = do  { c'       <- mapM cNameL c
        ; ty'      <- cvtType ty
        ; rec_flds <- mapM cvt_id_arg varstrtys
        ; let rec_ty = noLoc (HsFunTy noExt
                                           (noLoc $ HsRecTy noExt rec_flds) ty')
        ; returnL $ fst $ mkGadtDecl c' rec_ty }

cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
cvtSrcUnpackedness SourceNoUnpack       = SrcNoUnpack
cvtSrcUnpackedness SourceUnpack         = SrcUnpack

cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness
cvtSrcStrictness NoSourceStrictness = NoSrcStrict
cvtSrcStrictness SourceLazy         = SrcLazy
cvtSrcStrictness SourceStrict       = SrcStrict

cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)
cvt_arg (Bang su ss, ty)
  = do { ty'' <- cvtType ty
       ; ty' <- wrap_apps ty''
       ; let su' = cvtSrcUnpackedness su
       ; let ss' = cvtSrcStrictness ss
       ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' }

cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
cvt_id_arg (i, str, ty)
  = do  { L li i' <- vNameL i
        ; ty' <- cvt_arg (str,ty)
        ; return $ noLoc (ConDeclField
                          { cd_fld_ext = noExt
                          , cd_fld_names
                              = [L li $ FieldOcc noExt (L li i')]
                          , cd_fld_type =  ty'
                          , cd_fld_doc = Nothing}) }

cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs
                  ; returnL cs' }

cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
                               ; ys' <- mapM tNameL ys
                               ; returnL (xs', ys') }


------------------------------------------
--      Foreign declarations
------------------------------------------

cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD (ImportF callconv safety from nm ty)
  -- the prim and javascript calling conventions do not support headers
  -- and are inserted verbatim, analogous to mkImport in RdrHsSyn
  | callconv == TH.Prim || callconv == TH.JavaScript
  = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing
                    (CFunction (StaticTarget (SourceText from)
                                             (mkFastString from) Nothing
                                             True))
                    (noLoc $ quotedSourceText from))
  | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
                                 (mkFastString (TH.nameBase nm))
                                 from (noLoc $ quotedSourceText from)
  = mk_imp impspec
  | otherwise
  = failWith $ text (show from) <+> text "is not a valid ccall impent"
  where
    mk_imp impspec
      = do { nm' <- vNameL nm
           ; ty' <- cvtType ty
           ; return (ForeignImport { fd_i_ext = noExt
                                   , fd_name = nm'
                                   , fd_sig_ty = mkLHsSigType ty'
                                   , fd_fi = impspec })
           }
    safety' = case safety of
                     Unsafe     -> PlayRisky
                     Safe       -> PlaySafe
                     Interruptible -> PlayInterruptible

cvtForD (ExportF callconv as nm ty)
  = do  { nm' <- vNameL nm
        ; ty' <- cvtType ty
        ; let e = CExport (noLoc (CExportStatic (SourceText as)
                                                (mkFastString as)
                                                (cvt_conv callconv)))
                                                (noLoc (SourceText as))
        ; return $ ForeignExport { fd_e_ext = noExt
                                 , fd_name = nm'
                                 , fd_sig_ty = mkLHsSigType ty'
                                 , fd_fe = e } }

cvt_conv :: TH.Callconv -> CCallConv
cvt_conv TH.CCall      = CCallConv
cvt_conv TH.StdCall    = StdCallConv
cvt_conv TH.CApi       = CApiConv
cvt_conv TH.Prim       = PrimCallConv
cvt_conv TH.JavaScript = JavaScriptCallConv

------------------------------------------
--              Pragmas
------------------------------------------

cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
cvtPragmaD (InlineP nm inline rm phases)
  = do { nm' <- vNameL nm
       ; let dflt = dfltActivation inline
       ; let src TH.NoInline  = "{-# NOINLINE"
             src TH.Inline    = "{-# INLINE"
             src TH.Inlinable = "{-# INLINABLE"
       ; let ip   = InlinePragma { inl_src    = SourceText $ src inline
                                 , inl_inline = cvtInline inline
                                 , inl_rule   = cvtRuleMatch rm
                                 , inl_act    = cvtPhases phases dflt
                                 , inl_sat    = Nothing }
       ; returnJustL $ Hs.SigD noExt $ InlineSig noExt nm' ip }

cvtPragmaD (SpecialiseP nm ty inline phases)
  = do { nm' <- vNameL nm
       ; ty' <- cvtType ty
       ; let src TH.NoInline  = "{-# SPECIALISE NOINLINE"
             src TH.Inline    = "{-# SPECIALISE INLINE"
             src TH.Inlinable = "{-# SPECIALISE INLINE"
       ; let (inline', dflt,srcText) = case inline of
               Just inline1 -> (cvtInline inline1, dfltActivation inline1,
                                src inline1)
               Nothing      -> (NoUserInline,   AlwaysActive,
                                "{-# SPECIALISE")
       ; let ip = InlinePragma { inl_src    = SourceText srcText
                               , inl_inline = inline'
                               , inl_rule   = Hs.FunLike
                               , inl_act    = cvtPhases phases dflt
                               , inl_sat    = Nothing }
       ; returnJustL $ Hs.SigD noExt $ SpecSig noExt nm' [mkLHsSigType ty'] ip }

cvtPragmaD (SpecialiseInstP ty)
  = do { ty' <- cvtType ty
       ; returnJustL $ Hs.SigD noExt $
         SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }

cvtPragmaD (RuleP nm bndrs lhs rhs phases)
  = do { let nm' = mkFastString nm
       ; let act = cvtPhases phases AlwaysActive
       ; bndrs' <- mapM cvtRuleBndr bndrs
       ; lhs'   <- cvtl lhs
       ; rhs'   <- cvtl rhs
       ; returnJustL $ Hs.RuleD noExt
            $ HsRules noExt (SourceText "{-# RULES")
                      [noLoc $ HsRule noExt (noLoc (quotedSourceText nm,nm'))
                                                  act bndrs' lhs' rhs']
       }

cvtPragmaD (AnnP target exp)
  = do { exp' <- cvtl exp
       ; target' <- case target of
         ModuleAnnotation  -> return ModuleAnnProvenance
         TypeAnnotation n  -> do
           n' <- tconName n
           return (TypeAnnProvenance  (noLoc n'))
         ValueAnnotation n -> do
           n' <- vcName n
           return (ValueAnnProvenance (noLoc n'))
       ; returnJustL $ Hs.AnnD noExt
                     $ HsAnnotation noExt (SourceText "{-# ANN") target' exp'
       }

cvtPragmaD (LineP line file)
  = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))
       ; return Nothing
       }
cvtPragmaD (CompleteP cls mty)
  = do { cls' <- noLoc <$> mapM cNameL cls
       ; mty'  <- traverse tconNameL mty
       ; returnJustL $ Hs.SigD noExt
                   $ CompleteMatchSig noExt NoSourceText cls' mty' }

dfltActivation :: TH.Inline -> Activation
dfltActivation TH.NoInline = NeverActive
dfltActivation _           = AlwaysActive

cvtInline :: TH.Inline -> Hs.InlineSpec
cvtInline TH.NoInline  = Hs.NoInline
cvtInline TH.Inline    = Hs.Inline
cvtInline TH.Inlinable = Hs.Inlinable

cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
cvtRuleMatch TH.ConLike = Hs.ConLike
cvtRuleMatch TH.FunLike = Hs.FunLike

cvtPhases :: TH.Phases -> Activation -> Activation
cvtPhases AllPhases       dflt = dflt
cvtPhases (FromPhase i)   _    = ActiveAfter NoSourceText i
cvtPhases (BeforePhase i) _    = ActiveBefore NoSourceText i

cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)
cvtRuleBndr (RuleVar n)
  = do { n' <- vNameL n
       ; return $ noLoc $ Hs.RuleBndr noExt n' }
cvtRuleBndr (TypedRuleVar n ty)
  = do { n'  <- vNameL n
       ; ty' <- cvtType ty
       ; return $ noLoc $ Hs.RuleBndrSig noExt n' $ mkLHsSigWcType ty' }

---------------------------------------------------
--              Declarations
---------------------------------------------------

cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs doc ds
  | null ds
  = return (EmptyLocalBinds noExt)
  | otherwise
  = do { ds' <- cvtDecs ds
       ; let (binds, prob_sigs) = partitionWith is_bind ds'
       ; let (sigs, bads) = partitionWith is_sig prob_sigs
       ; unless (null bads) (failWith (mkBadDecMsg doc bads))
       ; return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs)) }

cvtClause :: HsMatchContext RdrName
          -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtClause ctxt (Clause ps body wheres)
  = do  { ps' <- cvtPats ps
        ; let pps = map (parenthesizePat appPrec) ps'
        ; g'  <- cvtGuard body
        ; ds' <- cvtLocalDecs (text "a where clause") wheres
        ; returnL $ Hs.Match noExt ctxt pps (GRHSs noExt g' (noLoc ds')) }


-------------------------------------------------------------------
--              Expressions
-------------------------------------------------------------------

cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
cvtl e = wrapL (cvt e)
  where
    cvt (VarE s)        = do { s' <- vName s; return $ HsVar noExt (noLoc s') }
    cvt (ConE s)        = do { s' <- cName s; return $ HsVar noExt (noLoc s') }
    cvt (LitE l)
      | overloadedLit l = go cvtOverLit (HsOverLit noExt)
                             (hsOverLitNeedsParens appPrec)
      | otherwise       = go cvtLit (HsLit noExt)
                             (hsLitNeedsParens appPrec)
      where
        go :: (Lit -> CvtM (l GhcPs))
           -> (l GhcPs -> HsExpr GhcPs)
           -> (l GhcPs -> Bool)
           -> CvtM (HsExpr GhcPs)
        go cvt_lit mk_expr is_compound_lit = do
          l' <- cvt_lit l
          let e' = mk_expr l'
          return $ if is_compound_lit l' then HsPar noExt (noLoc e') else e'
    cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
                                   ; return $ HsApp noExt (mkLHsPar x')
                                                          (mkLHsPar y')}
    cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y
                                   ; return $ HsApp noExt (mkLHsPar x')
                                                          (mkLHsPar y')}
    cvt (AppTypeE e t) = do { e' <- cvtl e
                            ; t' <- cvtType t
                            ; tp <- wrap_apps t'
                            ; let tp' = parenthesizeHsType appPrec tp
                            ; return $ HsAppType (mkHsWildCardBndrs tp') e' }
    cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its
                               -- own expression to avoid pretty-printing
                               -- oddities that can result from zero-argument
                               -- lambda expressions. See #13856.
    cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
                            ; let pats = map (parenthesizePat appPrec) ps'
                            ; return $ HsLam noExt (mkMatchGroup FromSource
                                             [mkSimpleMatch LambdaExpr
                                             pats e'])}
    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch CaseAlt) ms
                            ; return $ HsLamCase noExt
                                                   (mkMatchGroup FromSource ms')
                            }
    cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar noExt e' }
                                 -- Note [Dropping constructors]
                                 -- Singleton tuples treated like nothing (just parens)
    cvt (TupE es)      = do { es' <- mapM cvtl es
                            ; return $ ExplicitTuple noExt
                                             (map (noLoc . (Present noExt)) es')
                                                                         Boxed }
    cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es
                                   ; return $ ExplicitTuple noExt
                                           (map (noLoc . (Present noExt)) es')
                                                                       Unboxed }
    cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
                                       ; unboxedSumChecks alt arity
                                       ; return $ ExplicitSum noExt
                                                                   alt arity e'}
    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
                            ; return $ HsIf noExt (Just noSyntaxExpr) x' y' z' }
    cvt (MultiIfE alts)
      | null alts      = failWith (text "Multi-way if-expression with no alternatives")
      | otherwise      = do { alts' <- mapM cvtpair alts
                            ; return $ HsMultiIf noExt alts' }
    cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds
                            ; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'}
    cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
                            ; return $ HsCase noExt e'
                                                 (mkMatchGroup FromSource ms') }
    cvt (DoE ss)       = cvtHsDo DoExpr ss
    cvt (CompE ss)     = cvtHsDo ListComp ss
    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd
                            ; return $ ArithSeq noExt Nothing dd' }
    cvt (ListE xs)
      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s)
                                          ; return (HsLit noExt l') }
             -- Note [Converting strings]
      | otherwise       = do { xs' <- mapM cvtl xs
                             ; return $ ExplicitList noExt Nothing xs'
                             }

    -- Infix expressions
    cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
                                          ; let px = parenthesizeHsExpr opPrec x'
                                                py = parenthesizeHsExpr opPrec y'
                                          ; wrapParL (HsPar noExt) $
                                            OpApp noExt px s' py }
                                            -- Parenthesise both arguments and result,
                                            -- to ensure this operator application does
                                            -- does not get re-associated
                            -- See Note [Operator association]
    cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
                                          ; wrapParL (HsPar noExt) $
                                                          SectionR noExt s' y' }
                                            -- See Note [Sections in HsSyn] in HsExpr
    cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
                                          ; wrapParL (HsPar noExt) $
                                                          SectionL noExt x' s' }

    cvt (InfixE Nothing  s Nothing ) = do { s' <- cvtl s
                                          ; return $ HsPar noExt s' }
                                       -- Can I indicate this is an infix thing?
                                       -- Note [Dropping constructors]

    cvt (UInfixE x s y)  = do { x' <- cvtl x
                              ; let x'' = case x' of
                                            L _ (OpApp {}) -> x'
                                            _ -> mkLHsPar x'
                              ; cvtOpApp x'' s y } --  Note [Converting UInfix]

    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noExt e' }
    cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
                              ; let pe = parenthesizeHsExpr sigPrec e'
                              ; return $ ExprWithTySig (mkLHsSigWcType t') pe }
    cvt (RecConE c flds) = do { c' <- cNameL c
                              ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
                              ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
    cvt (RecUpdE e flds) = do { e' <- cvtl e
                              ; flds'
                                  <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
                                           flds
                              ; return $ mkRdrRecordUpd e' flds' }
    cvt (StaticE e)      = fmap (HsStatic noExt) $ cvtl e
    cvt (UnboundVarE s)  = do -- Use of 'vcName' here instead of 'vName' is
                              -- important, because UnboundVarE may contain
                              -- constructor names - see #14627.
                              { s' <- vcName s
                              ; return $ HsVar noExt (noLoc s') }
    cvt (LabelE s)       = do { return $ HsOverLabel noExt Nothing (fsLit s) }

{- Note [Dropping constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we drop constructors from the input (for instance, when we encounter @TupE [e]@)
we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@
could meet @UInfix@ constructors containing the @TupE [e]@. For example:

  UInfixE x * (TupE [UInfixE y + z])

If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet
and the above expression would be reassociated to

  OpApp (OpApp x * y) + z

which we don't want.
-}

cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)
       -> CvtM (LHsRecField' t (LHsExpr GhcPs))
cvtFld f (v,e)
  = do  { v' <- vNameL v; e' <- cvtl e
        ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'
                                     , hsRecFieldArg = e'
                                     , hsRecPun      = False}) }

cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)
cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }

{- Note [Operator assocation]
We must be quite careful about adding parens:
  * Infix (UInfix ...) op arg      Needs parens round the first arg
  * Infix (Infix ...) op arg       Needs parens round the first arg
  * UInfix (UInfix ...) op arg     No parens for first arg
  * UInfix (Infix ...) op arg      Needs parens round first arg


Note [Converting UInfix]
~~~~~~~~~~~~~~~~~~~~~~~~
When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust
the trees to reflect the fixities of the underlying operators:

  UInfixE x * (UInfixE y + z) ---> (x * y) + z

This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and
@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely
right-biased for types and left-biased for everything else. So we left-bias the
trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.

Sample input:

  UInfixE
   (UInfixE x op1 y)
   op2
   (UInfixE z op3 w)

Sample output:

  OpApp
    (OpApp
      (OpApp x op1 y)
      op2
      z)
    op3
    w

The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this
biasing.
-}

{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
The produced tree of infix expressions will be left-biased, provided @x@ is.

We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis
is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that
this holds for both branches (of @cvtOpApp@), provided we assume it holds for
the recursive calls to @cvtOpApp@.