From 7c60df10642d90d7205cb9c4296903b8de094029 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 24 May 2016 16:53:35 +0300 Subject: Change Hyperlinked lexer to know about DataKinds ticks --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 12 +++++++++++- haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs | 3 +++ 2 files changed, 14 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index e206413e..e4345602 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -31,12 +31,20 @@ chunk str@(c:_) chunk str | "--" `isPrefixOf` str = chunk' $ spanToNewline str | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str - | otherwise = case lex str of + | otherwise = case lex' str of (tok:_) -> chunk' tok [] -> [str] where chunk' (c, rest) = c:(chunk rest) +-- | A bit better lexer then the default, i.e. handles DataKinds quotes +lex' :: ReadS String +lex' ('\'' : '\'' : rest) = [("''", rest)] +lex' str@('\'' : '\\' : _ : '\'' : _) = lex str +lex' str@('\'' : _ : '\'' : _) = lex str +lex' ('\'' : rest) = [("'", rest)] +lex' str = lex str + -- | Split input to "first line" string and the rest of it. -- -- Ideally, this should be done simply with @'break' (== '\n')@. However, @@ -124,6 +132,8 @@ classify str | "--" `isPrefixOf` str = TkComment | "{-#" `isPrefixOf` str = TkPragma | "{-" `isPrefixOf` str = TkComment +classify "''" = TkSpecial +classify "'" = TkSpecial classify str@(c:_) | isSpace c = TkSpace | isDigit c = TkNumber diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs index 5f4dbc8c..b27ec4d8 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -12,16 +12,19 @@ data Token = Token , tkValue :: String , tkSpan :: Span } + deriving (Show) data Position = Position { posRow :: !Int , posCol :: !Int } + deriving (Show) data Span = Span { spStart :: Position , spEnd :: Position } + deriving (Show) data TokenType = TkIdentifier -- cgit v1.2.3 From 1dcefaddc52d968b20bb6107d620e1e0c6839970 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 3 Nov 2016 14:08:10 +0200 Subject: Match changes in GHC wip/T3384 branch --- haddock-api/src/Haddock/Backends/Hoogle.hs | 8 ++++---- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 6 ++++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 7 ++++--- haddock-api/src/Haddock/Convert.hs | 16 ++++++++-------- haddock-api/src/Haddock/Interface/Create.hs | 10 +++++----- haddock-api/src/Haddock/Interface/Rename.hs | 4 ++-- haddock-api/src/Haddock/Interface/Specialize.hs | 16 ++++++++-------- haddock-api/src/Haddock/Types.hs | 6 +++--- haddock-api/src/Haddock/Utils.hs | 2 +- 10 files changed, 40 insertions(+), 37 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 48b97445..40106491 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -16,7 +16,7 @@ module Haddock.Backends.Hoogle ( ppHoogle ) where -import BasicTypes (OverlapFlag(..), OverlapMode(..)) +import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..)) import InstEnv (ClsInst(..)) import Haddock.GhcUtils import Haddock.Types hiding (Version) @@ -85,7 +85,7 @@ dropHsDocTy = f f (HsDocTy a _) = f $ unL a f x = x -outHsType :: (OutputableBndr a, OutputableBndr (NameOrRdrName a)) +outHsType :: (OutputableBndrId a, HasOccNameId a) => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy @@ -196,7 +196,7 @@ ppInstance dflags x = -- safety information to a state where the Outputable instance -- produces no output which means no overlap and unsafe (or [safe] -- is generated). - cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap mempty + cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText , isSafeOverlap = False } } ppSynonym :: DynFlags -> TyClDecl Name -> [String] @@ -244,7 +244,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - resType = apps $ map (reL . HsTyVar . reL) $ + resType = apps $ map (reL . HsTyVar NotPromoted . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] ppCtor dflags _dat subdocs con@ConDeclGADT {} diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index be17cb8b..1d9fbe20 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -72,7 +72,7 @@ types = everything (<|>) ty where ty term = case cast term of - (Just (GHC.L sspan (GHC.HsTyVar name))) -> + (Just (GHC.L sspan (GHC.HsTyVar _ name))) -> pure (sspan, RtkType (GHC.unLoc name)) _ -> empty diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index ffb4d782..36a859e6 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -949,7 +949,8 @@ ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode , ppr_mono_lty pREC_TOP ty unicode ] ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty -ppr_mono_ty _ (HsTyVar (L _ name)) _ = ppDocName name +ppr_mono_ty _ (HsTyVar NotPromoted (L _ name)) _ = ppDocName name +ppr_mono_ty _ (HsTyVar Promoted (L _ name)) _ = char '\'' <> ppDocName name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) ppr_mono_ty _ (HsSumTy tys) u = sumParens (map (ppLType u) tys) @@ -960,7 +961,8 @@ ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys +ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys +ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index c6f1100b..499d9e11 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -984,12 +984,12 @@ ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual -- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar (L _ name)) True _ +ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ | getOccString (getName name) == "*" = toHtml "★" | getOccString (getName name) == "(->)" = toHtml "(→)" ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty -ppr_mono_ty _ (HsTyVar (L _ name)) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q = ppDocName q Prefix True name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) ppr_mono_ty _ (HsSumTy tys) u q = sumParens (map (ppLType u q) tys) @@ -1005,7 +1005,8 @@ ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}" -- placeholder in the signature, which is followed by the field -- declarations. ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys +ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys +ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q = brackets $ hsep $ punctuate comma $ map (ppLType u q) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy" diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 4e2ee05c..a99c5886 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -17,7 +17,7 @@ module Haddock.Convert where -- instance heads, which aren't TyThings, so just export everything. import Bag ( emptyBag ) -import BasicTypes ( TupleSort(..) ) +import BasicTypes ( TupleSort(..), SourceText(..) ) import Class import CoAxiom import ConLike @@ -80,7 +80,7 @@ tyThingToLHsDecl t = case t of , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl - , tcdSigs = noLoc (MinimalSig mempty . noLoc . fmap noLoc $ classMinimalDef cl) : + , tcdSigs = noLoc (MinimalSig NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyTcIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature @@ -366,17 +366,17 @@ synifyPatSynSigType :: PatSyn -> LHsSigType Name synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) synifyType :: SynifyTypeState -> Type -> LHsType Name -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv) +synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv) synifyType _ (TyConApp tc tys) -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473) | tc `hasKey` tYPETyConKey , [TyConApp lev []] <- tys , lev `hasKey` ptrRepLiftedDataConKey - = noLoc (HsTyVar (noLoc starKindTyConName)) + = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName)) | tc `hasKey` tYPETyConKey , [TyConApp lev []] <- tys , lev `hasKey` ptrRepUnliftedDataConKey - = noLoc (HsTyVar (noLoc unliftedTypeKindTyConName)) + = noLoc (HsTyVar NotPromoted (noLoc unliftedTypeKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc , tyConArity tc == length tys @@ -400,7 +400,7 @@ synifyType _ (TyConApp tc tys) -- Most TyCons: | otherwise = foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) - (noLoc $ HsTyVar $ noLoc (getName tc)) + (noLoc $ HsTyVar NotPromoted $ noLoc (getName tc)) (map (synifyType WithinType) $ filterOut isCoercionTy tys) synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 @@ -443,8 +443,8 @@ synifyPatSynType ps = let in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau synifyTyLit :: TyLit -> HsTyLit -synifyTyLit (NumTyLit n) = HsNumTy mempty n -synifyTyLit (StrTyLit s) = HsStrTy mempty s +synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n +synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 2cdc6f8b..4e1a9b3a 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -48,7 +48,7 @@ import Bag import RdrName import TcRnTypes import FastString (concatFS) -import BasicTypes ( StringLiteral(..) ) +import BasicTypes ( StringLiteral(..), SourceText(..) ) import qualified Outputable as O import HsDecls ( gadtDeclDetails,getConDetails ) @@ -164,7 +164,7 @@ mkAliasMap dflags mRenamedSource = Just (_,impDecls,_,_) -> M.fromList $ mapMaybe (\(SrcLoc.L _ impDecl) -> do - alias <- ideclAs impDecl + SrcLoc.L _ alias <- ideclAs impDecl return $ (lookupModuleDyn dflags (fmap Module.fsToUnitId $ @@ -569,7 +569,7 @@ mkExportItems L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef return [ mkExportDecl t (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] @@ -769,7 +769,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap expInst decl l name mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name mkExportItem decl@(L l d) | name:_ <- getMainDeclBinder d = expDecl decl l name @@ -839,7 +839,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = 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 (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs -- | Keep export items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index fa85ba64..40a10675 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -219,7 +219,7 @@ renameType t = case t of ltype' <- renameLType ltype return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar (L l n) -> return . HsTyVar . L l =<< rename n + HsTyVar ip (L l n) -> return . HsTyVar ip . L l =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype HsAppTy a b -> do @@ -262,7 +262,7 @@ renameType t = case t of HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a HsCoreTy a -> pure (HsCoreTy a) - HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b + 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 diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 3e0df4e1..28bbf305 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -36,7 +36,7 @@ specialize :: (Eq name, Typeable name) specialize name details = everywhere $ mkT step where - step (HsTyVar (L _ name')) | name == name' = details + step (HsTyVar _ (L _ name')) | name == name' = details step typ = typ @@ -123,7 +123,7 @@ sugar = sugarLists :: NamedThing name => HsType name -> HsType name -sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp) +sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp) | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp where name' = getName name @@ -137,7 +137,7 @@ sugarTuples 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)) + aux apps (HsTyVar _ (L _ name)) | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps where name' = getName name @@ -149,7 +149,7 @@ sugarTuples typ = sugarOperators :: NamedThing name => HsType name -> HsType name -sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar (L l name))) la)) lb) +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 where @@ -224,7 +224,7 @@ freeVariables = query term ctx = case cast term :: Maybe (HsType name) 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 $ getNameRep name, ctx) _ -> (Set.empty, ctx) @@ -267,7 +267,7 @@ renameType (HsQualTy lctxt lt) = HsQualTy <$> located renameContext lctxt <*> renameLType lt -renameType (HsTyVar name) = HsTyVar <$> located renameName name +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 @@ -285,8 +285,8 @@ 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 ph ltys) = - HsExplicitListTy ph <$> renameLTypes ltys +renameType (HsExplicitListTy ip ph ltys) = + HsExplicitListTy ip ph <$> renameLTypes ltys renameType (HsExplicitTupleTy phs ltys) = HsExplicitTupleTy phs <$> renameLTypes ltys renameType t@(HsTyLit _) = pure t diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 5220e6e9..951faf5b 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -344,7 +344,7 @@ data InstType name | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) | DataInst (TyClDecl name) -- ^ Data constructors -instance (OutputableBndr a, OutputableBndr (NameOrRdrName a)) +instance (OutputableBndrId a, HasOccNameId a) => Outputable (InstType a) where ppr (ClassInst { .. }) = text "ClassInst" <+> ppr clsiCtx @@ -380,8 +380,8 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl mkType (KindedTyVar (L loc name) lkind) = HsKindSig tvar lkind where - tvar = L loc (HsTyVar (L loc name)) - mkType (UserTyVar name) = HsTyVar name + tvar = L loc (HsTyVar NotPromoted (L loc name)) + mkType (UserTyVar name) = HsTyVar NotPromoted name -- | An instance head that may have documentation and a source location. diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index da87990c..ba382600 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -151,7 +151,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv))) + = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] -------------------------------------------------------------------------------- -- cgit v1.2.3 From f951caf888eabd8742059f26e516e3392658fc88 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Fri, 9 Dec 2016 19:56:39 +0200 Subject: Matching changes for GHC wip/T12942 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 3 ++- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 2 +- haddock-api/src/Haddock/Convert.hs | 11 +++++++-- haddock-api/src/Haddock/Interface/Rename.hs | 28 ++++++++++++++-------- haddock-api/src/Haddock/Types.hs | 2 +- 8 files changed, 34 insertions(+), 18 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 40106491..86a73c33 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -85,7 +85,7 @@ dropHsDocTy = f f (HsDocTy a _) = f $ unL a f x = x -outHsType :: (OutputableBndrId a, HasOccNameId a) +outHsType :: (OutputableBndrId a) => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy @@ -182,6 +182,7 @@ ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMet tyFamEqnToSyn tfe = SynDecl { tcdLName = tfe_tycon tfe , tcdTyVars = tfe_pats tfe + , tcdFixity = tfe_fixity tfe , tcdRhs = tfe_rhs tfe , tcdFVs = emptyNameSet } diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 1d9fbe20..aff61cfc 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -118,7 +118,7 @@ decls (group, _, _, _) = concatMap ($ group) where typ (GHC.L _ t) = case t of GHC.DataDecl { tcdLName = name } -> pure . decl $ name - GHC.SynDecl name _ _ _ -> pure . decl $ name + GHC.SynDecl name _ _ _ _ -> pure . decl $ name GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs fun term = case cast term of diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 8e9fd7ae..9fd55e49 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -47,7 +47,7 @@ import Data.Function import Data.Ord ( comparing ) import DynFlags (Language(..)) -import GHC hiding ( NoLink, moduleInfo,FunctionFixity(..) ) +import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) ) import Name import Module diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 499d9e11..adee2b67 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -34,7 +34,7 @@ import qualified Data.Map as Map import Data.Maybe import Text.XHtml hiding ( name, title, p, quote ) -import GHC hiding (FunctionFixity(..)) +import GHC hiding (LexicalFixity(..)) import GHC.Exts import Name import BooleanFormula diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs index 0f4dd51a..a84a55e8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -26,7 +26,7 @@ import Text.XHtml hiding ( name, title, p, quote ) import qualified Data.Map as M import qualified Data.List as List -import GHC hiding (FunctionFixity(..)) +import GHC hiding (LexicalFixity(..)) import Name import RdrName import FastString (unpackFS) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index a99c5886..6cf77de0 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -17,7 +17,7 @@ module Haddock.Convert where -- instance heads, which aren't TyThings, so just export everything. import Bag ( emptyBag ) -import BasicTypes ( TupleSort(..), SourceText(..) ) +import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..) ) import Class import CoAxiom import ConLike @@ -77,6 +77,7 @@ tyThingToLHsDecl t = case t of { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl , tcdTyVars = synifyTyVars (classTyVars cl) + , tcdFixity = Prefix , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl @@ -114,6 +115,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) in TyFamEqn { tfe_tycon = name , tfe_pats = HsIB { hsib_body = typats , hsib_vars = map tyVarName tkvs } + , tfe_fixity = Prefix , tfe_rhs = hs_rhs } synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) @@ -146,6 +148,8 @@ synifyTyCon _coax tc alphaTyVars --a, b, c... which are unfortunately all kind * , hsq_dependent = emptyNameSet } + , tcdFixity = Prefix + , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = noLoc [] @@ -180,6 +184,7 @@ synifyTyCon _coax tc FamilyDecl { fdInfo = i , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConTyVars tc) + , fdFixity = Prefix , fdResultSig = synifyFamilyResultSig resultVar (tyConResKind tc) , fdInjectivityAnn = @@ -191,6 +196,7 @@ synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConTyVars tc) + , tcdFixity = Prefix , tcdRhs = synifyType WithinType ty , tcdFVs = placeHolderNamesTc } | otherwise = @@ -233,7 +239,8 @@ synifyTyCon coax tc , dd_derivs = alg_deriv } in case lefts consRaw of [] -> return $ - DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn + DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdFixity = Prefix + , tcdDataDefn = defn , tcdDataCusk = False, tcdFVs = placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 40a10675..f88d9f4e 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -344,19 +344,19 @@ renameTyClD d = case d of decl' <- renameFamilyDecl decl return (FamDecl { tcdFam = decl' }) - SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do + SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs, tcdFVs = _fvs } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs - return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames }) + return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdRhs = rhs', tcdFVs = placeHolderNames }) - DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do + DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn, tcdFVs = _fvs } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn - return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames }) + return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames }) - ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars + ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do lcontext' <- renameLContext lcontext lname' <- renameL lname @@ -367,6 +367,7 @@ renameTyClD d = case d of at_defs' <- mapM renameLTyFamDefltEqn at_defs -- we don't need the default methods or the already collected doc entities return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' + , tcdFixity = fixity , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames }) @@ -380,7 +381,9 @@ renameTyClD d = case d of renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname - , fdTyVars = ltyvars, fdResultSig = result + , fdTyVars = ltyvars + , fdFixity = fixity + , fdResultSig = result , fdInjectivityAnn = injectivity }) = do info' <- renameFamilyInfo info lname' <- renameL lname @@ -388,7 +391,9 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity return (FamilyDecl { fdInfo = info', fdLName = lname' - , fdTyVars = ltyvars', fdResultSig = result' + , fdTyVars = ltyvars' + , fdFixity = fixity + , fdResultSig = result' , fdInjectivityAnn = injectivity' }) @@ -537,30 +542,33 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) , tfid_fvs = placeHolderNames }) } renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName) -renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs })) +renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity, tfe_rhs = rhs })) = do { tc' <- renameL tc ; pats' <- renameImplicit (mapM renameLType) pats ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' , tfe_pats = pats' + , tfe_fixity = fixity , tfe_rhs = rhs' })) } renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) -renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs })) +renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixity = fixity, tfe_rhs = rhs })) = do { tc' <- renameL tc ; tvs' <- renameLHsQTyVars tvs ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' , tfe_pats = tvs' + , tfe_fixity = fixity , tfe_rhs = rhs' })) } renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) -renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_defn = defn }) +renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fixity = fixity, dfid_defn = defn }) = do { tc' <- renameL tc ; pats' <- renameImplicit (mapM renameLType) pats ; defn' <- renameDataDefn defn ; return (DataFamInstDecl { dfid_tycon = tc' , dfid_pats = pats' + , dfid_fixity = fixity , dfid_defn = defn', dfid_fvs = placeHolderNames }) } renameImplicit :: (in_thing -> RnM out_thing) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 951faf5b..1f446224 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -344,7 +344,7 @@ data InstType name | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) | DataInst (TyClDecl name) -- ^ Data constructors -instance (OutputableBndrId a, HasOccNameId a) +instance (OutputableBndrId a) => Outputable (InstType a) where ppr (ClassInst { .. }) = text "ClassInst" <+> ppr clsiCtx -- cgit v1.2.3 From 7f1987b35eb7bb15ca2fd93321440af519dd8cd5 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 24 Jan 2017 21:57:56 +0200 Subject: Changes to match #13163 in GHC --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 8 ++++---- haddock-api/src/Haddock/Interface/Create.hs | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index aff61cfc..b97f0ead 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -152,11 +152,11 @@ imports src@(_, imps, _, _) = everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of - (Just (GHC.IEVar v)) -> pure $ var v - (Just (GHC.IEThingAbs t)) -> pure $ typ t - (Just (GHC.IEThingAll t)) -> pure $ typ t + (Just (GHC.IEVar v)) -> pure $ var $ GHC.ieLWrappedName v + (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t + (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t (Just (GHC.IEThingWith t _ vs _fls)) -> - [typ t] ++ map var vs + [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) var (GHC.L sspan name) = (sspan, RtkVar name) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 4e1a9b3a..4a65fc2a 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -511,10 +511,10 @@ mkExportItems Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls Just exports -> liftM concat $ mapM lookupExport exports where - lookupExport (IEVar (L _ x)) = declWith x - lookupExport (IEThingAbs (L _ t)) = declWith t - lookupExport (IEThingAll (L _ t)) = declWith t - lookupExport (IEThingWith (L _ t) _ _ _) = declWith t + lookupExport (IEVar (L _ x)) = declWith $ ieWrappedName x + lookupExport (IEThingAbs (L _ t)) = declWith $ ieWrappedName t + lookupExport (IEThingAll (L _ t)) = declWith $ ieWrappedName t + lookupExport (IEThingWith (L _ t) _ _ _) = declWith $ ieWrappedName t lookupExport (IEModuleContents (L _ m)) = moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $ -- cgit v1.2.3