diff options
Diffstat (limited to 'compiler/hsSyn/Convert.hs')
| -rw-r--r-- | compiler/hsSyn/Convert.hs | 149 |
1 files changed, 77 insertions, 72 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index e64c4eaed5..5ded8bcde3 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -6,6 +6,7 @@ This module converts Template Haskell syntax into HsSyn -} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} module Convert( convertToHsExpr, convertToPat, convertToHsDecls, @@ -46,20 +47,20 @@ import Language.Haskell.TH.Syntax as TH ------------------------------------------------------------------- -- The external interface -convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName] +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 RdrName) +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 RdrName) +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 RdrName) +convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs) convertToHsType loc t = initCvt loc $ wrapMsg "type" t $ cvtType t @@ -133,10 +134,10 @@ wrapL (CvtM m) = CvtM (\loc -> case m loc of Right (loc',v) -> Right (loc',L loc v)) ------------------------------------------------------------------- -cvtDecs :: [TH.Dec] -> CvtM [LHsDecl RdrName] +cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs] cvtDecs = fmap catMaybes . mapM cvtDec -cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName)) +cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs)) cvtDec (TH.ValD pat body ds) | TH.VarP s <- pat = do { s' <- vNameL s @@ -248,7 +249,7 @@ cvtDec (ClassD ctxt cl tvs fds decs) -- no docs in TH ^^ } where - cvt_at_def :: LTyFamInstDecl RdrName -> CvtM (LTyFamDefltEqn RdrName) + 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 @@ -384,7 +385,7 @@ cvtDec (TH.PatSynSigD nm ty) ; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') } ---------------- -cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName) +cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs) cvtTySynEqn tc (TySynEqn lhs rhs) = do { lhs' <- mapM (wrap_apps <=< cvtType) lhs ; rhs' <- cvtType rhs @@ -395,11 +396,11 @@ cvtTySynEqn tc (TySynEqn lhs rhs) ---------------- cvt_ci_decs :: MsgDoc -> [TH.Dec] - -> CvtM (LHsBinds RdrName, - [LSig RdrName], - [LFamilyDecl RdrName], - [LTyFamInstDecl RdrName], - [LDataFamInstDecl RdrName]) + -> 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 @@ -416,9 +417,9 @@ cvt_ci_decs doc decs ---------------- cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] - -> CvtM ( LHsContext RdrName + -> CvtM ( LHsContext GhcPs , Located RdrName - , LHsQTyVars RdrName) + , LHsQTyVars GhcPs) cvt_tycl_hdr cxt tc tvs = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc @@ -427,9 +428,9 @@ cvt_tycl_hdr cxt tc tvs } cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type] - -> CvtM ( LHsContext RdrName + -> CvtM ( LHsContext GhcPs , Located RdrName - , HsImplicitBndrs RdrName [LHsType RdrName]) + , HsImplicitBndrs GhcPs [LHsType GhcPs]) cvt_tyinst_hdr cxt tc tys = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc @@ -439,9 +440,9 @@ cvt_tyinst_hdr cxt tc tys ---------------- cvt_tyfam_head :: TypeFamilyHead -> CvtM ( Located RdrName - , LHsQTyVars RdrName - , Hs.LFamilyResultSig RdrName - , Maybe (Hs.LInjectivityAnn 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 @@ -453,23 +454,24 @@ cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity) -- Partitioning declarations ------------------------------------------------------------------- -is_fam_decl :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName) +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 RdrName -> Either (LTyFamInstDecl RdrName) (LHsDecl RdrName) +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 RdrName -> Either (LDataFamInstDecl RdrName) (LHsDecl RdrName) +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 RdrName -> Either (LSig RdrName) (LHsDecl RdrName) +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 RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName) +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 @@ -482,7 +484,7 @@ mkBadDecMsg doc bads -- Data types --------------------------------------------------- -cvtConstr :: TH.Con -> CvtM (LConDecl RdrName) +cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs) cvtConstr (NormalC c strtys) = do { c' <- cNameL c @@ -550,7 +552,7 @@ cvtSrcStrictness NoSourceStrictness = NoSrcStrict cvtSrcStrictness SourceLazy = SrcLazy cvtSrcStrictness SourceStrict = SrcStrict -cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType RdrName) +cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs) cvt_arg (Bang su ss, ty) = do { ty'' <- cvtType ty ; ty' <- wrap_apps ty'' @@ -558,7 +560,7 @@ cvt_arg (Bang su ss, ty) ; let ss' = cvtSrcStrictness ss ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' } -cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField RdrName) +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) @@ -568,7 +570,7 @@ cvt_id_arg (i, str, ty) , cd_fld_type = ty' , cd_fld_doc = Nothing}) } -cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving RdrName) +cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs) cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs ; returnL cs' } @@ -582,7 +584,7 @@ cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs -- Foreign declarations ------------------------------------------ -cvtForD :: Foreign -> CvtM (ForeignDecl RdrName) +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 @@ -635,7 +637,7 @@ cvt_conv TH.JavaScript = JavaScriptCallConv -- Pragmas ------------------------------------------ -cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName)) +cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs)) cvtPragmaD (InlineP nm inline rm phases) = do { nm' <- vNameL nm ; let dflt = dfltActivation inline @@ -727,7 +729,7 @@ cvtPhases AllPhases dflt = dflt cvtPhases (FromPhase i) _ = ActiveAfter NoSourceText i cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i -cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName) +cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs) cvtRuleBndr (RuleVar n) = do { n' <- vNameL n ; return $ noLoc $ Hs.RuleBndr n' } @@ -740,7 +742,7 @@ cvtRuleBndr (TypedRuleVar n ty) -- Declarations --------------------------------------------------- -cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName) +cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) cvtLocalDecs doc ds | null ds = return EmptyLocalBinds @@ -752,7 +754,7 @@ cvtLocalDecs doc ds ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) } cvtClause :: HsMatchContext RdrName - -> TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) + -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtClause ctxt (Clause ps body wheres) = do { ps' <- cvtPats ps ; pps <- mapM wrap_conpat ps' @@ -766,7 +768,7 @@ cvtClause ctxt (Clause ps body wheres) -- Expressions ------------------------------------------------------------------- -cvtl :: TH.Exp -> CvtM (LHsExpr RdrName) +cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs) cvtl e = wrapL (cvt e) where cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } @@ -875,14 +877,15 @@ and the above expression would be reassociated to which we don't want. -} -cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) -> CvtM (LHsRecField' t (LHsExpr RdrName)) +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 RdrName) +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' } @@ -940,7 +943,7 @@ the recursive calls to @cvtOpApp@. When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased since we have already run @cvtl@ on it. -} -cvtOpApp :: LHsExpr RdrName -> TH.Exp -> TH.Exp -> CvtM (HsExpr RdrName) +cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs) cvtOpApp x op1 (UInfixE y op2 z) = do { l <- wrapL $ cvtOpApp x op1 y ; cvtOpApp l op2 z } @@ -953,7 +956,7 @@ cvtOpApp x op y -- Do notation and statements ------------------------------------- -cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName) +cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs) cvtHsDo do_or_lc stmts | null stmts = failWith (text "Empty stmt list in do-block") | otherwise @@ -970,10 +973,10 @@ cvtHsDo do_or_lc stmts , nest 2 $ Outputable.ppr stmt , text "(It should be an expression.)" ] -cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName (LHsExpr RdrName)] +cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)] cvtStmts = mapM cvtStmt -cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName)) +cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs)) cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' } cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds @@ -983,7 +986,7 @@ cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' n cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) } cvtMatch :: HsMatchContext RdrName - -> TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) + -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtMatch ctxt (TH.Match p body decs) = do { p' <- cvtPat p ; lp <- case ctxt of @@ -994,18 +997,18 @@ cvtMatch ctxt (TH.Match p body decs) ; returnL $ Hs.Match ctxt [lp] Nothing (GRHSs g' (noLoc decs')) } -cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)] +cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)] cvtGuard (GuardedB pairs) = mapM cvtpair pairs cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] } -cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName (LHsExpr RdrName)) +cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)) cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs ; g' <- returnL $ mkBodyStmt ge' ; returnL $ GRHS [g'] rhs' } cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs ; returnL $ GRHS gs' rhs' } -cvtOverLit :: Lit -> CvtM (HsOverLit RdrName) +cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral (mkIntegralLit i) placeHolderType} cvtOverLit (RationalL r) @@ -1040,11 +1043,13 @@ allCharLs xs go cs (LitE (CharL c) : ys) = go (c:cs) ys go _ _ = Nothing -cvtLit :: Lit -> CvtM HsLit +cvtLit :: Lit -> CvtM (HsLit GhcPs) cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i } cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w } -cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (mkFractionalLit f) } -cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (mkFractionalLit f) } +cvtLit (FloatPrimL f) + = do { force f; return $ HsFloatPrim def (mkFractionalLit f) } +cvtLit (DoublePrimL f) + = do { force f; return $ HsDoublePrim def (mkFractionalLit f) } cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c } cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c } cvtLit (StringL s) = do { let { s' = mkFastString s } @@ -1061,13 +1066,13 @@ cvtLit _ = panic "Convert.cvtLit: Unexpected literal" quotedSourceText :: String -> SourceText quotedSourceText s = SourceText $ "\"" ++ s ++ "\"" -cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName] +cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs] cvtPats pats = mapM cvtPat pats -cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName) +cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs) cvtPat pat = wrapL (cvtp pat) -cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName) +cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs) cvtp (TH.LitP l) | overloadedLit l = do { l' <- cvtOverLit l ; return (mkNPat (noLoc l') Nothing) } @@ -1108,7 +1113,7 @@ cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p ; return $ ViewPat e' p' placeHolderType } -cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName)) +cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p) = do { L ls s' <- vNameL s; p' <- cvtPat p ; return (noLoc $ HsRecField { hsRecFieldLbl @@ -1116,7 +1121,7 @@ cvtPatFld (s,p) , hsRecFieldArg = p' , hsRecPun = False}) } -wrap_conpat :: Hs.LPat RdrName -> CvtM (Hs.LPat RdrName) +wrap_conpat :: Hs.LPat GhcPs -> CvtM (Hs.LPat GhcPs) wrap_conpat p@(L _ (ConPatIn _ (InfixCon{}))) = returnL $ ParPat p wrap_conpat p@(L _ (ConPatIn _ (PrefixCon []))) = return p wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _))) = returnL $ ParPat p @@ -1127,7 +1132,7 @@ The produced tree of infix patterns will be left-biased, provided @x@ is. See the @cvtOpApp@ documentation for how this function works. -} -cvtOpAppP :: Hs.LPat RdrName -> TH.Name -> TH.Pat -> CvtM (Hs.Pat RdrName) +cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs) cvtOpAppP x op1 (UInfixP y op2 z) = do { l <- wrapL $ cvtOpAppP x op1 y ; cvtOpAppP l op2 z } @@ -1139,10 +1144,10 @@ cvtOpAppP x op y ----------------------------------------------------------- -- Types and type variables -cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars RdrName) +cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs) cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } -cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName) +cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs) cvt_tv (TH.PlainTV nm) = do { nm' <- tNameL nm ; returnL $ UserTyVar nm' } @@ -1157,14 +1162,14 @@ cvtRole TH.RepresentationalR = Just Coercion.Representational cvtRole TH.PhantomR = Just Coercion.Phantom cvtRole TH.InferR = Nothing -cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName) +cvtContext :: TH.Cxt -> CvtM (LHsContext GhcPs) cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } -cvtPred :: TH.Pred -> CvtM (LHsType RdrName) +cvtPred :: TH.Pred -> CvtM (LHsType GhcPs) cvtPred = cvtType cvtDerivClause :: TH.DerivClause - -> CvtM (LHsDerivingClause RdrName) + -> CvtM (LHsDerivingClause GhcPs) cvtDerivClause (TH.DerivClause ds ctxt) = do { ctxt'@(L loc _) <- fmap (map mkLHsSigType) <$> cvtContext ctxt ; let ds' = fmap (L loc . cvtDerivStrategy) ds @@ -1175,10 +1180,10 @@ cvtDerivStrategy TH.StockStrategy = Hs.StockStrategy cvtDerivStrategy TH.AnyclassStrategy = Hs.AnyclassStrategy cvtDerivStrategy TH.NewtypeStrategy = Hs.NewtypeStrategy -cvtType :: TH.Type -> CvtM (LHsType RdrName) +cvtType :: TH.Type -> CvtM (LHsType GhcPs) cvtType = cvtTypeKind "type" -cvtTypeKind :: String -> TH.Type -> CvtM (LHsType RdrName) +cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs) cvtTypeKind ty_str ty = do { (head_ty, tys') <- split_ty_app ty ; case head_ty of @@ -1313,7 +1318,7 @@ cvtTypeKind ty_str ty } -- | Constructs an application of a type to arguments passed in a list. -mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName) +mk_apps :: HsType GhcPs -> [LHsType GhcPs] -> CvtM (LHsType GhcPs) mk_apps head_ty [] = returnL head_ty mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty @@ -1323,18 +1328,18 @@ mk_apps head_ty (ty:tys) = add_parens t@(L _ HsAppTy{}) = returnL (HsParTy t) add_parens t = return t -wrap_apps :: LHsType RdrName -> CvtM (LHsType RdrName) +wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs) wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t) wrap_apps t = return t -- | Constructs an arrow type with a specified return type -mk_arr_apps :: [LHsType RdrName] -> HsType RdrName -> CvtM (LHsType RdrName) +mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs) mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL - where go :: LHsType RdrName -> HsType RdrName -> CvtM (HsType RdrName) + where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs) go arg ret_ty = do { ret_ty_l <- returnL ret_ty ; return (HsFunTy arg ret_ty_l) } -split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName]) +split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType GhcPs]) split_ty_app ty = go ty [] where go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') } @@ -1347,7 +1352,7 @@ cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) {- | @cvtOpAppT x op y@ takes converted arguments and flattens any HsAppsTy structure in them. -} -cvtOpAppT :: LHsType RdrName -> RdrName -> LHsType RdrName -> LHsType RdrName +cvtOpAppT :: LHsType GhcPs -> RdrName -> LHsType GhcPs -> LHsType GhcPs cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _) = L (combineSrcSpans loc1 loc2) $ HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2') @@ -1362,21 +1367,21 @@ cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _) | otherwise = [noLoc $ HsAppPrefix t2] -cvtKind :: TH.Kind -> CvtM (LHsKind RdrName) +cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) cvtKind = cvtTypeKind "kind" -- | Convert Maybe Kind to a type family result signature. Used with data -- families where naming of the result is not possible (thus only kind or no -- signature is possible). cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind - -> CvtM (LFamilyResultSig RdrName) + -> CvtM (LFamilyResultSig GhcPs) cvtMaybeKindToFamilyResultSig Nothing = returnL Hs.NoSig cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki ; returnL (Hs.KindSig ki') } -- | Convert type family result signature. Used with both open and closed type -- families. -cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig RdrName) +cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs) cvtFamilyResultSig TH.NoSig = returnL Hs.NoSig cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki ; returnL (Hs.KindSig ki') } @@ -1385,13 +1390,13 @@ cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr -- | Convert injectivity annotation of a type family. cvtInjectivityAnnotation :: TH.InjectivityAnn - -> CvtM (Hs.LInjectivityAnn RdrName) + -> CvtM (Hs.LInjectivityAnn GhcPs) cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS) = do { annLHS' <- tNameL annLHS ; annRHS' <- mapM tNameL annRHS ; returnL (Hs.InjectivityAnn annLHS' annRHS') } -cvtPatSynSigTy :: TH.Type -> CvtM (LHsType RdrName) +cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs) -- pattern synonym types are of peculiar shapes, which is why we treat -- them separately from regular types; -- see Note [Pattern synonym type signatures and Template Haskell] |