From 01eeeb048acd2dd05ff6471ae148a97cf0720547 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 17 Oct 2017 15:00:02 +0200 Subject: Match changes for Trees that Grow in GHC --- haddock-api/src/Haddock/Interface/Create.hs | 30 +++-- haddock-api/src/Haddock/Interface/Rename.hs | 72 ++++++----- haddock-api/src/Haddock/Interface/Specialize.hs | 164 +++++++++++------------- 3 files changed, 130 insertions(+), 136 deletions(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 27456998..c6a67af0 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -454,12 +454,12 @@ subordinates instMap decl = case decl of cons = map unL $ (dd_cons dd) constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) | c <- cons, cname <- getConNames c ] - fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) + fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map getConDetails cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) , L _ n <- ns ] derivs = [ (instName, [unL doc], M.empty) - | HsIB { hsib_body = L l (HsDocTy _ doc) } + | HsIB { hsib_body = L l (HsDocTy _ _ doc) } <- concatMap (unLoc . deriv_clause_tys . unLoc) $ unLoc $ dd_derivs dd , Just instName <- [M.lookup l instMap] ] @@ -478,9 +478,9 @@ typeDocs d = where go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty) go n (HsQualTy { hst_body = ty }) = go n (unLoc ty) - go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty - go n (HsFunTy _ ty) = go (n+1) (unLoc ty) - go n (HsDocTy _ (L _ doc)) = M.singleton n doc + go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty + go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty) + go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc go _ _ = M.empty @@ -1031,7 +1031,7 @@ extractDecl name decl , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns - , selectorFieldOcc n == name + , extFieldOcc n == name ] in case matches of [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0) @@ -1057,17 +1057,18 @@ extractPatternSyn nm t tvs cons = typ = longArrow args (data_ty con) typ' = case con of - ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy cxt typ) + ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy PlaceHolder cxt typ) _ -> typ - typ'' = noLoc (HsQualTy (noLoc []) typ') + typ'' = noLoc (HsQualTy PlaceHolder (noLoc []) typ') in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'') - longArrow :: [LHsType name] -> LHsType name -> LHsType name - longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs + longArrow :: [LHsType (GhcPass name)] -> LHsType (GhcPass name) -> LHsType (GhcPass name) + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy PlaceHolder x y)) output inputs data_ty con | ConDeclGADT{} <- con = hsib_body $ con_type con - | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (HsAppTy PlaceHolder x y)) + (noLoc (HsTyVar PlaceHolder NotPromoted (noLoc t))) tvs extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn @@ -1076,16 +1077,17 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConDetails con of RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) + L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy PlaceHolder data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds - , L l n <- ns, selectorFieldOcc n == nm ] + , L l n <- ns, extFieldOcc n == nm ] data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = hsib_body $ con_type con - | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (HsAppTy PlaceHolder x y)) + (noLoc (HsTyVar PlaceHolder NotPromoted (noLoc t))) tvs -- | Keep export items with docs. pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 7023a908..c7e4f6f8 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -212,61 +212,61 @@ renameType t = case t of HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do tyvars' <- mapM renameLTyVarBndr tyvars ltype' <- renameLType ltype - return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' }) + return (HsForAllTy { hst_xforall = PlaceHolder, hst_bndrs = tyvars', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) + return (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar ip (L l n) -> return . HsTyVar ip . L l =<< rename n - HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype + HsTyVar _ ip (L l n) -> return . HsTyVar PlaceHolder ip . L l =<< rename n + HsBangTy _ b ltype -> return . HsBangTy PlaceHolder b =<< renameLType ltype - HsAppTy a b -> do + HsAppTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsAppTy a' b') + return (HsAppTy PlaceHolder a' b') - HsFunTy a b -> do + HsFunTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsFunTy a' b') + return (HsFunTy PlaceHolder a' b') - HsListTy ty -> return . HsListTy =<< renameLType ty - HsPArrTy ty -> return . HsPArrTy =<< renameLType ty - HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty) - HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2) + HsListTy _ ty -> return . (HsListTy PlaceHolder) =<< renameLType ty + HsPArrTy _ ty -> return . (HsPArrTy PlaceHolder) =<< renameLType ty + HsIParamTy _ n ty -> liftM (HsIParamTy PlaceHolder n) (renameLType ty) + HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy PlaceHolder) (renameLType ty1) (renameLType ty2) - HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - HsSumTy ts -> HsSumTy <$> mapM renameLType ts + HsTupleTy _ b ts -> return . HsTupleTy PlaceHolder b =<< mapM renameLType ts + HsSumTy _ ts -> HsSumTy PlaceHolder <$> mapM renameLType ts - HsOpTy a (L loc op) b -> do + HsOpTy _ a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy a' (L loc op') b') + return (HsOpTy PlaceHolder a' (L loc op') b') - HsParTy ty -> return . HsParTy =<< renameLType ty + HsParTy _ ty -> return . (HsParTy PlaceHolder) =<< renameLType ty - HsKindSig ty k -> do + HsKindSig _ ty k -> do ty' <- renameLType ty k' <- renameLKind k - return (HsKindSig ty' k') + return (HsKindSig PlaceHolder ty' k') - HsDocTy ty doc -> do + HsDocTy _ ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc - return (HsDocTy ty' doc') + return (HsDocTy PlaceHolder ty' doc') - HsTyLit x -> return (HsTyLit x) + HsTyLit _ x -> return (HsTyLit PlaceHolder x) - HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a - HsCoreTy a -> pure (HsCoreTy a) - HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b - HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b - HsSpliceTy _ _ -> error "renameType: HsSpliceTy" - HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a - HsAppsTy _ -> error "renameType: HsAppsTy" + HsRecTy _ a -> HsRecTy PlaceHolder <$> mapM renameConDeclFieldField a + (XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a)) + HsExplicitListTy x i b -> HsExplicitListTy x i <$> mapM renameLType b + HsExplicitTupleTy x b -> HsExplicitTupleTy x <$> mapM renameLType b + HsSpliceTy _ _ -> error "renameType: HsSpliceTy" + HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a + HsAppsTy _ _ -> error "renameType: HsAppsTy" renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) @@ -275,13 +275,14 @@ renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI) -renameLTyVarBndr (L loc (UserTyVar (L l n))) +renameLTyVarBndr (L loc (UserTyVar x (L l n))) = do { n' <- rename n - ; return (L loc (UserTyVar (L l n'))) } -renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) + ; return (L loc (UserTyVar x (L l n'))) } +renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind - ; return (L loc (KindedTyVar (L lv n') kind')) } + ; return (L loc (KindedTyVar x (L lv n') kind')) } +renameLTyVarBndr (L _ (XTyVarBndr _ )) = error "haddock:renameLTyVarBndr" renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do @@ -466,9 +467,10 @@ renameConDeclFieldField (L l (ConDeclField names t doc)) = do return $ L l (ConDeclField names' t' doc') renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) -renameLFieldOcc (L l (FieldOcc lbl sel)) = do +renameLFieldOcc (L l (FieldOcc sel lbl)) = do sel' <- rename sel - return $ L l (FieldOcc lbl sel') + return $ L l (FieldOcc sel' lbl) +renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc" renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 6d2888d3..0cac818d 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -28,20 +28,19 @@ import Data.Set (Set) import qualified Data.Set as Set -- | Instantiate all occurrences of given names with corresponding types. -specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name)) - => Data a - => [(IdP name, HsType name)] -> a -> a +specialize :: Data a + => [(Name, HsType GhcRn)] -> a -> a specialize specs = go where go :: forall x. Data x => x -> x - go = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var + go = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var strip_kind_sig :: HsType name -> HsType name - strip_kind_sig (HsKindSig (L _ t) _) = t + strip_kind_sig (HsKindSig _ (L _ t) _) = t strip_kind_sig typ = typ - specialize_ty_var :: HsType name -> HsType name - specialize_ty_var (HsTyVar _ (L _ name')) + specialize_ty_var :: HsType GhcRn -> HsType GhcRn + specialize_ty_var (HsTyVar _ _ (L _ name')) | Just t <- Map.lookup name' spec_map = t specialize_ty_var typ = typ -- This is a tricky recursive definition that is guaranteed to terminate @@ -54,35 +53,33 @@ specialize specs = go -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. -specializeTyVarBndrs :: (Ord (IdP name), DataId name, NamedThing (IdP name)) - => Data a - => LHsQTyVars name -> [HsType name] +specializeTyVarBndrs :: Data a + => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs - bname (UserTyVar (L _ name)) = name - bname (KindedTyVar (L _ name) _) = name + bname (UserTyVar _ (L _ name)) = name + bname (KindedTyVar _ (L _ name) _) = name + bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs" -specializePseudoFamilyDecl :: (Ord (IdP name), DataId name, NamedThing (IdP name)) - => LHsQTyVars name -> [HsType name] - -> PseudoFamilyDecl name - -> PseudoFamilyDecl name +specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn] + -> PseudoFamilyDecl GhcRn + -> PseudoFamilyDecl GhcRn specializePseudoFamilyDecl bndrs typs decl = decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)} -specializeSig :: forall name . (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name)) - => LHsQTyVars name -> [HsType name] - -> Sig name - -> Sig name +specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] + -> Sig GhcRn + -> Sig GhcRn specializeSig bndrs typs (TypeSig lnames typ) = TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) where - true_type :: HsType name + true_type :: HsType GhcRn true_type = unLoc (hsSigWcType typ) - typ' :: HsType name + typ' :: HsType GhcRn typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type fv = foldr Set.union Set.empty . map freeVariables $ typs specializeSig _ _ sig = sig @@ -90,8 +87,7 @@ specializeSig _ _ sig = sig -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type. -specializeInstHead :: (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name)) - => InstHead name -> InstHead name +specializeInstHead :: InstHead GhcRn -> InstHead GhcRn specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = ihd { ihdInstType = instType' } where @@ -110,27 +106,26 @@ specializeInstHead ihd = ihd -- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This -- can be fixed using 'sugar' function, that will turn such types into @[a]@ -- and @(a, b, c)@. -sugar :: forall name. (NamedThing (IdP name), DataId name) - => HsType name -> HsType name +sugar :: HsType GhcRn -> HsType GhcRn sugar = sugarOperators . sugarTuples . sugarLists -sugarLists :: NamedThing (IdP name) => HsType name -> HsType name -sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp) - | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp +sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) +sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp) + | isBuiltInSyntax name' && strName == "[]" = HsListTy PlaceHolder ltyp where name' = getName name strName = occNameString . nameOccName $ name' sugarLists typ = typ -sugarTuples :: NamedThing (IdP name) => HsType name -> HsType name +sugarTuples :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarTuples typ = aux [] typ where - aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp - aux apps (HsParTy (L _ typ')) = aux apps typ' - aux apps (HsTyVar _ (L _ name)) - | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps + aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp + aux apps (HsParTy _ (L _ typ')) = aux apps typ' + aux apps (HsTyVar _ _ (L _ name)) + | isBuiltInSyntax name' && suitable = HsTupleTy PlaceHolder HsBoxedTuple apps where name' = getName name strName = occNameString . nameOccName $ name' @@ -140,10 +135,10 @@ sugarTuples typ = aux _ _ = typ -sugarOperators :: NamedThing (IdP name) => HsType name -> HsType name -sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb) +sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) +sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb + | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy PlaceHolder la lb where name' = getName name sugarOperators typ = typ @@ -208,15 +203,15 @@ setInternalOccName occ name = -- | Compute set of free variables of given type. -freeVariables :: forall name. (NamedThing (IdP name), DataId name) - => HsType name -> Set Name +freeVariables :: forall p. (NamedThing (IdP p), DataId p, Typeable p) + => HsType p -> Set Name freeVariables = everythingWithState Set.empty Set.union query where - query term ctx = case cast term :: Maybe (HsType name) of - Just (HsForAllTy bndrs _) -> + query term ctx = case cast term :: Maybe (HsType p) of + Just (HsForAllTy _ bndrs _) -> (Set.empty, Set.union ctx (bndrsNames bndrs)) - Just (HsTyVar _ (L _ name)) + Just (HsTyVar _ _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx) @@ -231,8 +226,7 @@ freeVariables = -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something -- like @(a -> b0) -> b@). -rename :: (Eq (IdP name), DataId name, SetName (IdP name)) - => Set Name-> HsType name -> HsType name +rename :: Set Name -> HsType GhcRn -> HsType GhcRn rename fv typ = evalState (renameType typ) env where env = RenameEnv @@ -252,63 +246,58 @@ data RenameEnv name = RenameEnv } -renameType :: (Eq (IdP name), SetName (IdP name)) - => HsType name -> Rename (IdP name) (HsType name) -renameType (HsForAllTy bndrs lt) = - HsForAllTy +renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) +renameType (HsForAllTy x bndrs lt) = + HsForAllTy x <$> mapM (located renameBinder) bndrs <*> renameLType lt -renameType (HsQualTy lctxt lt) = - HsQualTy +renameType (HsQualTy x lctxt lt) = + HsQualTy x <$> located renameContext lctxt <*> renameLType lt -renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name -renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la -renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr -renameType (HsListTy lt) = HsListTy <$> renameLType lt -renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt -renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt -renameType (HsSumTy lt) = HsSumTy <$> mapM renameLType lt -renameType (HsOpTy la lop lb) = - HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb -renameType (HsParTy lt) = HsParTy <$> renameLType lt -renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt -renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb -renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk +renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name +renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la +renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr +renameType (HsListTy x lt) = HsListTy x <$> renameLType lt +renameType (HsPArrTy x lt) = HsPArrTy x <$> renameLType lt +renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt +renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt +renameType (HsOpTy x la lop lb) = + HsOpTy x <$> renameLType la <*> located renameName lop <*> renameLType lb +renameType (HsParTy x lt) = HsParTy x <$> renameLType lt +renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt +renameType (HsEqTy x la lb) = HsEqTy x <$> renameLType la <*> renameLType lb +renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk renameType t@(HsSpliceTy _ _) = pure t -renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc -renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt -renameType t@(HsRecTy _) = pure t -renameType t@(HsCoreTy _) = pure t -renameType (HsExplicitListTy ip ph ltys) = - HsExplicitListTy ip ph <$> renameLTypes ltys -renameType (HsExplicitTupleTy phs ltys) = - HsExplicitTupleTy phs <$> renameLTypes ltys -renameType t@(HsTyLit _) = pure t +renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc +renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt +renameType t@(HsRecTy _ _) = pure t +renameType t@(XHsType (NHsCoreTy _)) = pure t +renameType (HsExplicitListTy x ip ltys) = + HsExplicitListTy x ip <$> renameLTypes ltys +renameType (HsExplicitTupleTy x ltys) = + HsExplicitTupleTy x <$> renameLTypes ltys +renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) -renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming" +renameType (HsAppsTy _ _) = error "HsAppsTy: Only used before renaming" -renameLType :: (Eq (IdP name), SetName (IdP name)) - => LHsType name -> Rename (IdP name) (LHsType name) +renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn) renameLType = located renameType -renameLTypes :: (Eq (IdP name), SetName (IdP name)) - => [LHsType name] -> Rename (IdP name) [LHsType name] +renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] renameLTypes = mapM renameLType -renameContext :: (Eq (IdP name), SetName (IdP name)) - => HsContext name -> Rename (IdP name) (HsContext name) +renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes -renameBinder :: (Eq (IdP name), SetName (IdP name)) - => HsTyVarBndr name -> Rename (IdP name) (HsTyVarBndr name) -renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname -renameBinder (KindedTyVar lname lkind) = - KindedTyVar <$> located renameName lname <*> located renameType lkind - +renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn) +renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname +renameBinder (KindedTyVar x lname lkind) = + KindedTyVar x <$> located renameName lname <*> located renameType lkind +renameBinder (XTyVarBndr _) = error "haddock:renameBinder" -- | Core renaming logic. renameName :: (Eq name, SetName name) => name -> Rename name name @@ -363,5 +352,6 @@ located f (L loc e) = L loc <$> f e tyVarName :: HsTyVarBndr name -> IdP name -tyVarName (UserTyVar name) = unLoc name -tyVarName (KindedTyVar (L _ name) _) = name +tyVarName (UserTyVar _ name) = unLoc name +tyVarName (KindedTyVar _ (L _ name) _) = name +tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName" -- cgit v1.2.3