aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs81
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs71
-rw-r--r--haddock-api/src/Haddock/Interface/Json.hs5
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs103
-rw-r--r--haddock-api/src/Haddock/Interface/ParseModuleHeader.hs3
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs112
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs24
7 files changed, 213 insertions, 186 deletions
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 2d72d117..dd6c70a5 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, MagicHash, BangPatterns #-}
+{-# LANGUAGE MagicHash, BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
@@ -19,6 +19,7 @@ import Haddock.Types
import Haddock.Convert
import Haddock.GhcUtils
+import Control.Applicative ((<|>))
import Control.Arrow hiding ((<+>))
import Data.List
import Data.Ord (comparing)
@@ -31,7 +32,6 @@ import DynFlags
import CoreSyn (isOrphan)
import ErrUtils
import FamInstEnv
-import FastString
import GHC
import InstEnv
import Module ( ModuleSet, moduleSetElts )
@@ -39,13 +39,11 @@ import MonadUtils (liftIO)
import Name
import NameEnv
import Outputable (text, sep, (<+>))
-import PrelNames
import SrcLoc
import TyCon
import TyCoRep
-import TysPrim( funTyCon )
+import TysPrim( funTyConName )
import Var hiding (varName)
-#define FSLIT(x) (mkFastString# (x#))
type ExportedNames = Set.Set Name
type Modules = Set.Set Module
@@ -63,16 +61,24 @@ attachInstances expInfo ifaces instIfaceMap mods = do
ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]
attach index iface = do
- newItems <- mapM (attachToExportItem index expInfo iface ifaceMap instIfaceMap)
+
+ let getInstDoc = findInstDoc iface ifaceMap instIfaceMap
+ getFixity = findFixity iface ifaceMap instIfaceMap
+
+ newItems <- mapM (attachToExportItem index expInfo getInstDoc getFixity)
(ifaceExportItems iface)
- let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface)
+ let orphanInstances = attachOrphanInstances expInfo getInstDoc (ifaceInstances iface)
return $ iface { ifaceExportItems = newItems
, ifaceOrphanInstances = orphanInstances
}
-attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GhcRn]
-attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
- [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n), Nothing)
+attachOrphanInstances
+ :: ExportInfo
+ -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance
+ -> [ClsInst] -- ^ a list of orphan instances
+ -> [DocInstance GhcRn]
+attachOrphanInstances expInfo getInstDoc cls_instances =
+ [ (synifyInstHead i, getInstDoc n, (L (getSrcSpan n) n), Nothing)
| let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ]
, (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
, not $ isInstanceHidden expInfo cls tys
@@ -80,40 +86,40 @@ attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
attachToExportItem
- :: NameEnv ([ClsInst], [FamInst])
+ :: NameEnv ([ClsInst], [FamInst]) -- ^ all instances (that we know of)
-> ExportInfo
- -> Interface
- -> IfaceMap
- -> InstIfaceMap
+ -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance
+ -> (Name -> Maybe Fixity) -- ^ how to lookup a fixity
-> ExportItem GhcRn
-> Ghc (ExportItem GhcRn)
-attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
+attachToExportItem index expInfo getInstDoc getFixity export =
case attachFixities export of
e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do
insts <-
let mb_instances = lookupNameEnv index (tcdName d)
cls_instances = maybeToList mb_instances >>= fst
fam_instances = maybeToList mb_instances >>= snd
- fam_insts = [ ( synifyFamInst i opaque
- , doc
- , spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d))
+ fam_insts = [ ( synFamInst
+ , getInstDoc n
+ , spanNameE n synFamInst (L eSpan (tcdName d))
, nameModule_maybe n
)
| i <- sortBy (comparing instFam) fam_instances
, let n = getName i
- , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap
, not $ isNameHidden expInfo (fi_fam i)
, not $ any (isTypeHidden expInfo) (fi_tys i)
, let opaque = isTypeHidden expInfo (fi_rhs i)
+ , let synFamInst = synifyFamInst i opaque
]
- cls_insts = [ ( synifyInstHead i
- , instLookup instDocMap n iface ifaceMap instIfaceMap
- , spanName n (synifyInstHead i) (L eSpan (tcdName d))
+ cls_insts = [ ( synClsInst
+ , getInstDoc n
+ , spanName n synClsInst (L eSpan (tcdName d))
, nameModule_maybe n
)
| let is = [ (instanceSig i, getName i) | i <- cls_instances ]
, (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
, not $ isInstanceHidden expInfo cls tys
+ , let synClsInst = synifyInstHead i
]
-- fam_insts but with failing type fams filtered out
cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ]
@@ -133,7 +139,7 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
nubByName fst $ expItemFixities e ++
[ (n',f) | n <- getMainDeclBinder d
, n' <- n : (map fst subDocs ++ patsyn_names)
- , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]
+ , f <- maybeToList (getFixity n')
] }
where
patsyn_names = concatMap (getMainDeclBinder . fst) patsyns
@@ -152,16 +158,20 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
let L l r = spanName s ok linst
in L l (Right r)
+-- | Lookup the doc associated with a certain instance
+findInstDoc :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe (MDoc Name)
+findInstDoc iface ifaceMap instIfaceMap = \name ->
+ (Map.lookup name . ifaceDocMap $ iface) <|>
+ (Map.lookup name . ifaceDocMap =<< Map.lookup (nameModule name) ifaceMap) <|>
+ (Map.lookup name . instDocMap =<< Map.lookup (nameModule name) instIfaceMap)
+
+-- | Lookup the fixity associated with a certain name
+findFixity :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe Fixity
+findFixity iface ifaceMap instIfaceMap = \name ->
+ (Map.lookup name . ifaceFixMap $ iface) <|>
+ (Map.lookup name . ifaceFixMap =<< Map.lookup (nameModule name) ifaceMap) <|>
+ (Map.lookup name . instFixMap =<< Map.lookup (nameModule name) instIfaceMap)
-instLookup :: (InstalledInterface -> Map.Map Name a) -> Name
- -> Interface -> IfaceMap -> InstIfaceMap -> Maybe a
-instLookup f name iface ifaceMap instIfaceMap =
- case Map.lookup name (f $ toInstalledIface iface) of
- res@(Just _) -> res
- Nothing -> do
- let ifaceMaps = Map.union (fmap toInstalledIface ifaceMap) instIfaceMap
- iface' <- Map.lookup (nameModule name) ifaceMaps
- Map.lookup name (f iface')
--------------------------------------------------------------------------------
-- Collecting and sorting instances
@@ -211,13 +221,6 @@ instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t }
= (map argCount ts, n, map simplify ts, argCount t, simplify t)
-funTyConName :: Name
-funTyConName = mkWiredInName gHC_PRIM
- (mkOccNameFS tcName FSLIT("(->)"))
- funTyConKey
- (ATyCon funTyCon) -- Relevant TyCon
- BuiltInSyntax
-
--------------------------------------------------------------------------------
-- Filtering hidden instances
--------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 146c3cc8..463411b4 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -20,27 +20,21 @@
module Haddock.Interface.Create (createInterface) where
import Documentation.Haddock.Doc (metaDocAppend)
-import Documentation.Haddock.Utf8 as Utf8
import Haddock.Types
import Haddock.Options
import Haddock.GhcUtils
import Haddock.Utils
import Haddock.Convert
import Haddock.Interface.LexParseRn
-import Haddock.Backends.Hyperlinker.Types
-import Haddock.Backends.Hyperlinker.Ast as Hyperlinker
-import Haddock.Backends.Hyperlinker.Parser as Hyperlinker
import Data.Bifunctor
import Data.Bitraversable
-import qualified Data.ByteString as BS
import qualified Data.Map as M
import Data.Map (Map)
import Data.List
import Data.Maybe
import Data.Ord
import Control.Applicative
-import Control.Exception (evaluate)
import Control.Monad
import Data.Traversable
@@ -59,9 +53,8 @@ import Bag
import RdrName
import TcRnTypes
import FastString ( unpackFS, fastStringToByteString)
-import BasicTypes ( StringLiteral(..), SourceText(..) )
+import BasicTypes ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
import qualified Outputable as O
-import HsDecls ( getConArgs )
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -117,7 +110,7 @@ createInterface tm flags modMap instIfaceMap = do
let declsWithDocs = topDecls group_
- exports0 = fmap (reverse . map (first unLoc)) mayExports
+ exports0 = fmap (map (first unLoc)) mayExports
exports
| OptIgnoreExports `elem` opts = Nothing
| otherwise = exports0
@@ -170,8 +163,6 @@ createInterface tm flags modMap instIfaceMap = do
modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
- tokenizedSrc <- mkMaybeTokenizedSrc dflags flags tm
-
return $! Interface {
ifaceMod = mdl
, ifaceIsSig = is_sig
@@ -197,7 +188,8 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceRnOrphanInstances = [] -- Filled in `renameInterface`
, ifaceHaddockCoverage = coverage
, ifaceWarningMap = warningMap
- , ifaceTokenizedSrc = tokenizedSrc
+ , ifaceHieFile = Just $ ml_hie_file $ ms_location ms
+ , ifaceDynFlags = dflags
}
@@ -899,7 +891,7 @@ hiDecl dflags t = do
Nothing -> do
liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]
return Nothing
- Just x -> case tyThingToLHsDecl x of
+ Just x -> case tyThingToLHsDecl ShowRuntimeRep x of
Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing
Right (m, t') -> liftErrMsg (tell $ map bugWarn m)
>> return (Just $ noLoc t')
@@ -1077,8 +1069,8 @@ extractDecl declMap name decl
TyClD _ d@DataDecl {} ->
let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
in if isDataConName name
- then SigD noExt <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
- else SigD noExt <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
+ then SigD noExt <$> extractPatternSyn name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d))
+ else SigD noExt <$> extractRecSel name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d))
TyClD _ FamDecl {}
| isValName name
, Just (famInst:_) <- M.lookup name declMap
@@ -1113,10 +1105,11 @@ extractDecl declMap name decl
in case matches of
[d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0)
_ -> error "internal: extractDecl (ClsInstD)"
- _ -> error "internal: extractDecl"
-
+ _ -> O.pprPanic "extractDecl" $
+ O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":"
+ O.$$ O.nest 4 (O.ppr decl)
-extractPatternSyn :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn
+extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn
extractPatternSyn nm t tvs cons =
case filter matches cons of
[] -> error "extractPatternSyn: constructor pattern not found"
@@ -1144,9 +1137,13 @@ extractPatternSyn nm t tvs cons =
data_ty con
| ConDeclGADT{} <- con = con_res_ty con
- | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs
+ where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn
+ mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty
+ mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki
+ mkAppTyArg f (HsArgPar _) = HsParTy noExt f
-extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn]
+extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]
-> LSig GhcRn
extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
@@ -1162,7 +1159,11 @@ extractRecSel nm t tvs (L _ con : rest) =
data_ty
-- ResTyGADT _ ty <- con_res con = ty
| ConDeclGADT{} <- con = con_res_ty con
- | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs
+ where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn
+ mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty
+ mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki
+ mkAppTyArg f (HsArgPar _) = HsParTy noExt f
-- | Keep export items with docs.
pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn]
@@ -1192,34 +1193,6 @@ seqList :: [a] -> ()
seqList [] = ()
seqList (x : xs) = x `seq` seqList xs
-mkMaybeTokenizedSrc :: DynFlags -> [Flag] -> TypecheckedModule
- -> ErrMsgGhc (Maybe [RichToken])
-mkMaybeTokenizedSrc dflags flags tm
- | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of
- Just src -> do
- tokens <- liftGhcToErrMsgGhc (liftIO (mkTokenizedSrc dflags summary src))
- return $ Just tokens
- Nothing -> do
- liftErrMsg . tell . pure $ concat
- [ "Warning: Cannot hyperlink module \""
- , moduleNameString . ms_mod_name $ summary
- , "\" because renamed source is not available"
- ]
- return Nothing
- | otherwise = return Nothing
- where
- summary = pm_mod_summary . tm_parsed_module $ tm
-
-mkTokenizedSrc :: DynFlags -> ModSummary -> RenamedSource -> IO [RichToken]
-mkTokenizedSrc dflags ms src = do
- -- make sure to read the whole file at once otherwise
- -- we run out of file descriptors (see #495)
- rawSrc <- BS.readFile (msHsFilePath ms) >>= evaluate
- let tokens = Hyperlinker.parse dflags filepath (Utf8.decodeUtf8 rawSrc)
- return $ Hyperlinker.enrich src tokens
- where
- filepath = msHsFilePath ms
-
-- | Find a stand-alone documentation comment by its name.
findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString)
findNamedDoc name = search
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index 636d3e19..a9834fa0 100644
--- a/haddock-api/src/Haddock/Interface/Json.hs
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -62,7 +62,10 @@ jsonMDoc MetaDoc{..} =
]
jsonDoc :: Doc Name -> JsonDoc
-jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc))
+jsonDoc doc = jsonString (show (bimap showModName showName doc))
+ where
+ showModName = showWrapped (moduleNameString . fst)
+ showName = showWrapped nameStableString
jsonModule :: Module -> JsonDoc
jsonModule = JSString . moduleStableString
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index b6913012..0b40ed3c 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -19,9 +19,9 @@ module Haddock.Interface.LexParseRn
, processModuleHeader
) where
-import Avail
import Control.Arrow
import Control.Monad
+import Data.Functor (($>))
import Data.List
import Data.Ord
import Documentation.Haddock.Doc (metaDocConcat)
@@ -34,8 +34,8 @@ import Haddock.Types
import Name
import Outputable ( showPpr, showSDoc )
import RdrName
+import RdrHsSyn (setRdrNameSpace)
import EnumSet
-import RnEnv (dataTcOccs)
processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString]
-> ErrMsgM (Maybe (MDoc Name))
@@ -89,24 +89,38 @@ processModuleHeader dflags pkgName gre safety mayStr = do
-- fallbacks in case we can't locate the identifiers.
--
-- See the comments in the source for implementation commentary.
-rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name)
+rename :: DynFlags -> GlobalRdrEnv -> Doc NsRdrName -> ErrMsgM (Doc Name)
rename dflags gre = rn
where
rn d = case d of
DocAppend a b -> DocAppend <$> rn a <*> rn b
DocParagraph doc -> DocParagraph <$> rn doc
- DocIdentifier x -> do
+ DocIdentifier i -> do
+ let NsRdrName ns x = unwrap i
+ occ = rdrNameOcc x
+ isValueName = isDataOcc occ || isVarOcc occ
+
+ let valueNsChoices | isValueName = [x]
+ | otherwise = [] -- is this ever possible?
+ typeNsChoices | isValueName = [setRdrNameSpace x tcName]
+ | otherwise = [x]
+
-- Generate the choices for the possible kind of thing this
- -- is.
- let choices = dataTcOccs x
+ -- is. We narrow down the possibilities with the namespace (if
+ -- there is one).
+ let choices = case ns of
+ Value -> valueNsChoices
+ Type -> typeNsChoices
+ None -> valueNsChoices ++ typeNsChoices
-- Lookup any GlobalRdrElts that match the choices.
case concatMap (\c -> lookupGRE_RdrName c gre) choices of
-- We found no names in the env so we start guessing.
[] ->
case choices of
- -- This shouldn't happen as 'dataTcOccs' always returns at least its input.
- [] -> pure (DocMonospaced (DocString (showPpr dflags x)))
+ -- The only way this can happen is if a value namespace was
+ -- specified on something that cannot be a value.
+ [] -> invalidValue dflags i
-- There was nothing in the environment so we need to
-- pick some default from what's available to us. We
@@ -116,14 +130,14 @@ rename dflags gre = rn
-- type constructor names (such as in #253). So now we
-- only get type constructor links if they are actually
-- in scope.
- a:_ -> outOfScope dflags a
+ a:_ -> outOfScope dflags ns (i $> a)
-- There is only one name in the environment that matches so
-- use it.
- [a] -> pure (DocIdentifier (gre_name a))
+ [a] -> pure (DocIdentifier (i $> gre_name a))
-- There are multiple names available.
- gres -> ambiguous dflags x gres
+ gres -> ambiguous dflags i gres
DocWarning doc -> DocWarning <$> rn doc
DocEmphasis doc -> DocEmphasis <$> rn doc
@@ -135,7 +149,7 @@ rename dflags gre = rn
DocCodeBlock doc -> DocCodeBlock <$> rn doc
DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)
DocModule str -> pure (DocModule str)
- DocHyperlink l -> pure (DocHyperlink l)
+ DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l
DocPic str -> pure (DocPic str)
DocMathInline str -> pure (DocMathInline str)
DocMathDisplay str -> pure (DocMathDisplay str)
@@ -155,19 +169,25 @@ rename dflags gre = rn
-- users shouldn't rely on this doing the right thing. See tickets
-- #253 and #375 on the confusion this causes depending on which
-- default we pick in 'rename'.
-outOfScope :: DynFlags -> RdrName -> ErrMsgM (Doc a)
-outOfScope dflags x =
- case x of
- Unqual occ -> warnAndMonospace occ
- Qual mdl occ -> pure (DocIdentifierUnchecked (mdl, occ))
- Orig _ occ -> warnAndMonospace occ
- Exact name -> warnAndMonospace name -- Shouldn't happen since x is out of scope
+outOfScope :: DynFlags -> Namespace -> Wrap RdrName -> ErrMsgM (Doc a)
+outOfScope dflags ns x =
+ case unwrap x of
+ Unqual occ -> warnAndMonospace (x $> occ)
+ Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ)))
+ Orig _ occ -> warnAndMonospace (x $> occ)
+ Exact name -> warnAndMonospace (x $> name) -- Shouldn't happen since x is out of scope
where
+ prefix = case ns of
+ Value -> "the value "
+ Type -> "the type "
+ None -> ""
+
warnAndMonospace a = do
- tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope.\n" ++
+ let a' = showWrapped (showPpr dflags) a
+ tell ["Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++
" If you qualify the identifier, haddock can try to link it anyway."]
- pure (monospaced a)
- monospaced a = DocMonospaced (DocString (showPpr dflags a))
+ pure (monospaced a')
+ monospaced = DocMonospaced . DocString
-- | Handle ambiguous identifiers.
--
@@ -175,26 +195,39 @@ outOfScope dflags x =
--
-- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class.
ambiguous :: DynFlags
- -> RdrName
+ -> Wrap NsRdrName
-> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above.
-> ErrMsgM (Doc Name)
ambiguous dflags x gres = do
- let noChildren = map availName (gresToAvailInfo gres)
- dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren
- msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++
- concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++
+ let dflt = maximumBy (comparing (gre_lcl &&& isTyConName . gre_name)) gres
+ msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++
+ concatMap (\n -> " * " ++ defnLoc n ++ "\n") gres ++
" You may be able to disambiguate the identifier by qualifying it or\n" ++
- " by hiding some imports.\n" ++
- " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt
+ " by specifying the type/value namespace explicitly.\n" ++
+ " Defaulting to the one defined " ++ defnLoc dflt
-- TODO: Once we have a syntax for namespace qualification (#667) we may also
-- want to emit a warning when an identifier is a data constructor for a type
-- of the same name, but not the only constructor.
-- For example, for @data D = C | D@, someone may want to reference the @D@
-- constructor.
- when (length noChildren > 1) $ tell [msg]
- pure (DocIdentifier dflt)
+ when (length (gresToAvailInfo gres) > 1) $ tell [msg]
+ pure (DocIdentifier (x $> gre_name dflt))
+ where
+ defnLoc = showSDoc dflags . pprNameDefnLoc . gre_name
+
+-- | Handle value-namespaced names that cannot be for values.
+--
+-- Emits a warning that the value-namespace is invalid on a non-value identifier.
+invalidValue :: DynFlags -> Wrap NsRdrName -> ErrMsgM (Doc a)
+invalidValue dflags x = do
+ tell ["Warning: " ++ showNsRdrName dflags x ++ " cannot be value, yet it is\n" ++
+ " namespaced as such. Did you mean to specify a type namespace\n" ++
+ " instead?"]
+ pure (DocMonospaced (DocString (showNsRdrName dflags x)))
+
+-- | Printable representation of a wrapped and namespaced name
+showNsRdrName :: DynFlags -> Wrap NsRdrName -> String
+showNsRdrName dflags = (\p i -> p ++ "'" ++ i ++ "'") <$> prefix <*> ident
where
- isLocalName (nameSrcLoc -> RealSrcLoc {}) = True
- isLocalName _ = False
- x_str = '\'' : showPpr dflags x ++ "'"
- defnLoc = showSDoc dflags . pprNameDefnLoc
+ ident = showWrapped (showPpr dflags . rdrName)
+ prefix = renderNs . namespace . unwrap
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
index 6ac2f186..37813d16 100644
--- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -18,7 +18,6 @@ import Data.Char
import DynFlags
import Haddock.Parser
import Haddock.Types
-import RdrName
-- -----------------------------------------------------------------------------
-- Parsing module headers
@@ -26,7 +25,7 @@ import RdrName
-- NB. The headers must be given in the order Module, Description,
-- Copyright, License, Maintainer, Stability, Portability, except that
-- any or all may be omitted.
-parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName)
+parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName)
parseModuleHeader dflags pkgName str0 =
let
kvs :: [(String, String)]
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 1c976410..ceea2444 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.Rename
@@ -23,15 +24,15 @@ import GHC hiding (NoLink)
import Name
import Outputable ( panic )
import RdrName (RdrName(Exact))
-import PrelNames (eqTyCon_RDR)
+import TysWiredIn (eqTyCon_RDR)
import Control.Applicative
+import Control.Arrow ( first )
import Control.Monad hiding (mapM)
import Data.List
import qualified Data.Map as Map hiding ( Map )
import Prelude hiding (mapM)
-
renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
renameInterface dflags renamingEnv warnings iface =
@@ -92,56 +93,53 @@ renameInterface dflags renamingEnv warnings iface =
--------------------------------------------------------------------------------
-- Monad for renaming
---
--- The monad does two things for us: it passes around the environment for
--- renaming, and it returns a list of names which couldn't be found in
--- the environment.
--------------------------------------------------------------------------------
+-- | The monad does two things for us: it passes around the environment for
+-- renaming, and it returns a list of names which couldn't be found in
+-- the environment.
newtype RnM a =
- RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function
- -> (a,[Name])
+ RnM { unRn :: (Name -> (Bool, DocName))
+ -- Name lookup function. The 'Bool' indicates that if the name
+ -- was \"found\" in the environment.
+
+ -> (a, [Name] -> [Name])
+ -- Value returned, as well as a difference list of the names not
+ -- found
}
instance Monad RnM where
- (>>=) = thenRn
- return = pure
+ m >>= k = RnM $ \lkp -> let (a, out1) = unRn m lkp
+ (b, out2) = unRn (k a) lkp
+ in (b, out1 . out2)
instance Functor RnM where
- fmap f x = do a <- x; return (f a)
+ fmap f (RnM lkp) = RnM (first f . lkp)
instance Applicative RnM where
- pure = returnRn
- (<*>) = ap
-
-returnRn :: a -> RnM a
-returnRn a = RnM (const (a,[]))
-thenRn :: RnM a -> (a -> RnM b) -> RnM b
-m `thenRn` k = RnM (\lkp -> case unRn m lkp of
- (a,out1) -> case unRn (k a) lkp of
- (b,out2) -> (b,out1++out2))
-
-getLookupRn :: RnM (Name -> (Bool, DocName))
-getLookupRn = RnM (\lkp -> (lkp,[]))
-
-outRn :: Name -> RnM ()
-outRn name = RnM (const ((),[name]))
+ pure a = RnM (const (a, id))
+ mf <*> mx = RnM $ \lkp -> let (f, out1) = unRn mf lkp
+ (x, out2) = unRn mx lkp
+ in (f x, out1 . out2)
+-- | Look up a 'Name' in the renaming environment.
lookupRn :: Name -> RnM DocName
-lookupRn name = do
- lkp <- getLookupRn
+lookupRn name = RnM $ \lkp ->
case lkp name of
- (False,maps_to) -> do outRn name; return maps_to
- (True, maps_to) -> return maps_to
-
-
-runRnFM :: LinkEnv -> RnM a -> (a,[Name])
-runRnFM env rn = unRn rn lkp
+ (False,maps_to) -> (maps_to, (name :))
+ (True, maps_to) -> (maps_to, id)
+
+-- | Run the renamer action using lookup in a 'LinkEnv' as the lookup function.
+-- Returns the renamed value along with a list of `Name`'s that could not be
+-- renamed because they weren't in the environment.
+runRnFM :: LinkEnv -> RnM a -> (a, [Name])
+runRnFM env rn = let (x, dlist) = unRn rn lkp in (x, dlist [])
where
- lkp n = case Map.lookup n env of
- Nothing -> (False, Undocumented n)
- Just mdl -> (True, Documented n mdl)
+ lkp n | isTyVarName n = (True, Undocumented n)
+ | otherwise = case Map.lookup n env of
+ Nothing -> (False, Undocumented n)
+ Just mdl -> (True, Documented n mdl)
--------------------------------------------------------------------------------
@@ -175,8 +173,8 @@ renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
renameLDocHsSyn = return
-renameDoc :: Traversable t => t Name -> RnM (t DocName)
-renameDoc = traverse rename
+renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName))
+renameDoc = traverse (traverse rename)
renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
renameFnArgsDoc = mapM renameDoc
@@ -185,6 +183,13 @@ renameFnArgsDoc = mapM renameDoc
renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI)
renameLType = mapM renameType
+renameLTypeArg :: LHsTypeArg GhcRn -> RnM (LHsTypeArg DocNameI)
+renameLTypeArg (HsValArg ty) = do { ty' <- renameLType ty
+ ; return $ HsValArg ty' }
+renameLTypeArg (HsTypeArg l ki) = do { ki' <- renameLKind ki
+ ; return $ HsTypeArg l ki' }
+renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp
+
renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI)
renameLSigType = renameImplicit renameLType
@@ -240,6 +245,11 @@ renameType t = case t of
b' <- renameLType b
return (HsAppTy NoExt a' b')
+ HsAppKindTy _ a b -> do
+ a' <- renameLType a
+ b' <- renameLKind b
+ return (HsAppKindTy NoExt a' b')
+
HsFunTy _ a b -> do
a' <- renameLType a
b' <- renameLType b
@@ -276,7 +286,7 @@ renameType t = case t of
HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b
HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
HsSpliceTy _ s -> renameHsSpliceTy s
- HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
+ HsWildCardTy a -> pure (HsWildCardTy a)
-- | Rename splices, but _only_ those that turn out to be for types.
-- I think this is actually safe for our possible inputs:
@@ -311,9 +321,6 @@ renameLContext (L loc context) = do
context' <- mapM renameLType context
return (L loc context')
-renameWildCardInfo :: HsWildCardInfo -> RnM HsWildCardInfo
-renameWildCardInfo (AnonWildCard (L l name)) = return (AnonWildCard (L l name))
-
renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI)
renameInstHead InstHead {..} = do
cname <- rename ihdClsName
@@ -600,13 +607,16 @@ renameTyFamInstEqn eqn
rename_ty_fam_eqn
:: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn)
-> RnM (FamEqn DocNameI (HsTyPats DocNameI) (LHsType DocNameI))
- rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats
- , feqn_fixity = fixity, feqn_rhs = rhs })
+ rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
+ , feqn_pats = pats, feqn_fixity = fixity
+ , feqn_rhs = rhs })
= do { tc' <- renameL tc
- ; pats' <- mapM renameLType pats
+ ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs
+ ; pats' <- mapM renameLTypeArg pats
; rhs' <- renameLType rhs
; return (FamEqn { feqn_ext = noExt
, feqn_tycon = tc'
+ , feqn_bndrs = bndrs'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = rhs' }) }
@@ -620,6 +630,7 @@ renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs
; rhs' <- renameLType rhs
; return (L loc (FamEqn { feqn_ext = noExt
, feqn_tycon = tc'
+ , feqn_bndrs = Nothing -- this is always Nothing
, feqn_pats = tvs'
, feqn_fixity = fixity
, feqn_rhs = rhs' })) }
@@ -633,13 +644,16 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
rename_data_fam_eqn
:: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn)
-> RnM (FamEqn DocNameI (HsTyPats DocNameI) (HsDataDefn DocNameI))
- rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats
- , feqn_fixity = fixity, feqn_rhs = defn })
+ rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
+ , feqn_pats = pats, feqn_fixity = fixity
+ , feqn_rhs = defn })
= do { tc' <- renameL tc
- ; pats' <- mapM renameLType pats
+ ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs
+ ; pats' <- mapM renameLTypeArg pats
; defn' <- renameDataDefn defn
; return (FamEqn { feqn_ext = noExt
, feqn_tycon = tc'
+ , feqn_bndrs = bndrs'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = defn' }) }
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 30931c26..6fd528af 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -15,6 +15,8 @@ import Haddock.Types
import GHC
import Name
import FastString
+import TysPrim ( funTyConName )
+import TysWiredIn ( listTyConName )
import Control.Monad
import Control.Monad.Trans.State
@@ -47,14 +49,13 @@ specialize specs = go spec_map0
-- one by one, we should avoid infinite loops.
spec_map0 = foldr (\(n,t) acc -> Map.insert n (go acc t) acc) mempty specs
+{-# SPECIALIZE specialize :: [(Name, HsType GhcRn)] -> HsType GhcRn -> HsType GhcRn #-}
-- | Instantiate given binders with corresponding types.
--
-- 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 :: Data a
- => LHsQTyVars GhcRn -> [HsType GhcRn]
- -> a -> a
+specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn
specializeTyVarBndrs bndrs typs =
specialize $ zip bndrs' typs
where
@@ -64,11 +65,12 @@ specializeTyVarBndrs bndrs typs =
bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs"
+
specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn]
-> PseudoFamilyDecl GhcRn
-> PseudoFamilyDecl GhcRn
specializePseudoFamilyDecl bndrs typs decl =
- decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)}
+ decl {pfdTyVars = map (fmap (specializeTyVarBndrs bndrs typs)) (pfdTyVars decl)}
specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]
-> Sig GhcRn
@@ -110,10 +112,7 @@ sugar = sugarOperators . sugarTuples . sugarLists
sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp)
- | isBuiltInSyntax name' && strName == "[]" = HsListTy NoExt ltyp
- where
- name' = getName name
- strName = occNameString . nameOccName $ name'
+ | getName name == listTyConName = HsListTy NoExt ltyp
sugarLists typ = typ
@@ -127,7 +126,7 @@ sugarTuples typ =
| isBuiltInSyntax name' && suitable = HsTupleTy NoExt HsBoxedTuple apps
where
name' = getName name
- strName = occNameString . nameOccName $ name'
+ strName = getOccString name
suitable = case parseTupleArity strName of
Just arity -> arity == length apps
Nothing -> False
@@ -137,7 +136,7 @@ sugarTuples typ =
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 NoExt la lb
+ | funTyConName == name' = HsFunTy NoExt la lb
where
name' = getName name
sugarOperators typ = typ
@@ -182,7 +181,7 @@ parseTupleArity _ = Nothing
type NameRep = FastString
getNameRep :: NamedThing name => name -> NameRep
-getNameRep = occNameFS . getOccName
+getNameRep = getOccFS
nameRepString :: NameRep -> String
nameRepString = unpackFS
@@ -256,6 +255,7 @@ renameType (HsQualTy x lctxt lt) =
renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name
renameType t@(HsStarTy _ _) = pure t
renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la
+renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk
renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr
renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt
@@ -281,6 +281,8 @@ renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType = located renameType
+renameLKind :: LHsKind GhcRn -> Rename (IdP GhcRn) (LHsKind GhcRn)
+renameLKind = renameLType
renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
renameLTypes = mapM renameLType