aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs24
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs4
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs53
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs18
5 files changed, 44 insertions, 57 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index b4a605f2..63acb465 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -82,7 +82,7 @@ dropHsDocTy = f
f (HsOpTy x a b c) = HsOpTy x (g a) b (g c)
f (HsParTy x a) = HsParTy x (g a)
f (HsKindSig x a b) = HsKindSig x (g a) b
- f (HsDocTy _ a _) = f $ unL a
+ f (HsDocTy _ a _) = f $ unLoc a
f x = x
outHsType :: (OutputableBndrId p)
@@ -215,7 +215,7 @@ ppSynonym dflags x = [out dflags x]
ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]
ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs
= showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} :
- concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)
+ concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn)
where
-- GHC gives out "data Bar =", we want to delete the equals.
@@ -244,22 +244,22 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
[out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs]
- funs = foldr1 (\x y -> reL $ HsFunTy noExtField x y)
- apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
+ funs = foldr1 (\x y -> noLoc $ HsFunTy noExtField x y)
+ apps = foldl1 (\x y -> noLoc $ HsAppTy noExtField x y)
- typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
+ typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unLoc $ funs flds)
-- We print the constructors as comma-separated list. See GHC
-- docs for con_names on why it is a list to begin with.
- name = commaSeparate dflags . map unL $ getConNames con
+ name = commaSeparate dflags . map unLoc $ getConNames con
- resType = let c = HsTyVar noExtField NotPromoted (reL (tcdName dat))
+ resType = let c = HsTyVar noExtField NotPromoted (noLoc (tcdName dat))
as = map (tyVarBndr2Type . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)
- in apps (map reL (c : as))
+ in apps (map noLoc (c : as))
tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn
tyVarBndr2Type (UserTyVar _ n) = HsTyVar noExtField NotPromoted n
- tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) k
+ tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (noLoc (HsTyVar noExtField NotPromoted n)) k
tyVarBndr2Type (XTyVarBndr nec) = noExtCon nec
ppCtor dflags _dat subdocs con@(ConDeclGADT { })
@@ -267,8 +267,8 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { })
where
f = [typeSig name (getGADTConTypeG con)]
- typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)
- name = out dflags $ map unL $ getConNames con
+ typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unLoc ty)
+ name = out dflags $ map unLoc $ getConNames con
ppCtor _ _ _ (XConDecl nec) = noExtCon nec
ppFixity :: DynFlags -> (Name, Fixity) -> [String]
@@ -298,7 +298,7 @@ docWith dflags header d
mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String]
mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s
where
- getDoc = maybe [] (return . fst) (lookup (unL n) subdocs)
+ getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs)
data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String
deriving Show
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index d52c136f..647812f9 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -624,7 +624,7 @@ ppClassDecl instances doc subdocs
text "\\haddockpremethods{}" <> emph (text "Associated Types") $$
vcat [ ppFamDecl True (fst doc) [] (FamDecl noExtField decl) True
| L _ decl <- ats
- , let name = unL . fdLName $ decl
+ , let name = unLoc . fdLName $ decl
doc = lookupAnySubdoc name subdocs
]
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 25669ca7..ef0ba1b6 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -492,7 +492,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
+++ shortSubDecls False
(
[ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats
- , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++
+ , let doc = lookupAnySubdoc (unLoc $ fdLName $ unLoc at) subdocs ] ++
-- ToDo: add associated type defaults
@@ -544,7 +544,7 @@ ppClassDecl summary links instances fixities loc d subdocs
<+>
subDefaults (maybeToList defTys)
| at <- ats
- , let name = unL . fdLName $ unL at
+ , let name = unLoc . fdLName $ unLoc at
doc = lookupAnySubdoc name subdocs
subfixs = filter ((== name) . fst) fixities
defTys = (declElem . ppDefaultAssocTy name) <$> lookupDAT name
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index f600997a..923516b6 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -319,8 +319,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
case con_args d of
PrefixCon _ -> Just d
RecCon fields
- | all field_avail (unL fields) -> Just d
- | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) })
+ | all field_avail (unLoc fields) -> Just d
+ | otherwise -> Just (d { con_args = PrefixCon (field_types (map unLoc (unLoc fields))) })
-- if we have *all* the field names available, then
-- keep the record declaration. Otherwise degrade to
-- a constructor declaration. This isn't quite right, but
@@ -340,7 +340,7 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]
-restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
+restrictATs names ats = [ at | at <- ats , unLoc (fdLName (unLoc at)) `elem` names ]
-------------------------------------------------------------------------------
@@ -444,18 +444,6 @@ reparenConDeclField c@XConDeclField{} = c
-------------------------------------------------------------------------------
--- * Located
--------------------------------------------------------------------------------
-
-
-unL :: Located a -> a
-unL (L _ x) = x
-
-
-reL :: a -> Located a
-reL = L undefined
-
--------------------------------------------------------------------------------
-- * NamedThing instances
-------------------------------------------------------------------------------
@@ -475,17 +463,17 @@ class Parent a where
instance Parent (ConDecl GhcRn) where
children con =
case con_args con of
- RecCon fields -> map (extFieldOcc . unL) $
- concatMap (cd_fld_names . unL) (unL fields)
+ RecCon fields -> map (extFieldOcc . unLoc) $
+ concatMap (cd_fld_names . unLoc) (unLoc fields)
_ -> []
instance Parent (TyClDecl GhcRn) where
children d
- | isDataDecl d = map unL $ concatMap (getConNames . unL)
+ | isDataDecl d = map unLoc $ concatMap (getConNames . unLoc)
$ (dd_cons . tcdDataDefn) $ d
| isClassDecl d =
- map (unL . fdLName . unL) (tcdATs d) ++
- [ unL n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ]
+ map (unLoc . fdLName . unLoc) (tcdATs d) ++
+ [ unLoc n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ]
| otherwise = []
@@ -495,13 +483,13 @@ family = getName &&& children
familyConDecl :: ConDecl GHC.GhcRn -> [(Name, [Name])]
-familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d)
+familyConDecl d = zip (map unLoc (getConNames d)) (repeat $ children d)
-- | A mapping from the parent (main-binder) to its children and from each
-- child to its grand-children, recursively.
families :: TyClDecl GhcRn -> [(Name, [Name])]
families d
- | isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d))
+ | isDataDecl d = family d : concatMap (familyConDecl . unLoc) (dd_cons (tcdDataDefn d))
| isClassDecl d = [family d]
| otherwise = []
@@ -546,17 +534,16 @@ minimalDef n = do
-- * DynFlags
-------------------------------------------------------------------------------
-
-setObjectDir, setHiDir, setHieDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags
-setObjectDir f d = d{ objectDir = Just f}
-setHiDir f d = d{ hiDir = Just f}
-setHieDir f d = d{ hieDir = Just f}
-setStubDir f d = d{ stubDir = Just f
- , includePaths = addGlobalInclude (includePaths d) [f] }
- -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
- -- \#included from the .hc file when compiling with -fvia-C.
-setOutputDir f = setObjectDir f . setHiDir f . setHieDir f . setStubDir f
-
+-- TODO: use `setOutputDir` from GHC
+setOutputDir :: FilePath -> DynFlags -> DynFlags
+setOutputDir dir dynFlags =
+ dynFlags { objectDir = Just dir
+ , hiDir = Just dir
+ , hieDir = Just dir
+ , stubDir = Just dir
+ , includePaths = addGlobalInclude (includePaths dynFlags) [dir]
+ , dumpDir = Just dir
+ }
-------------------------------------------------------------------------------
-- * 'StringBuffer' and 'ByteString'
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index b182a615..af006d03 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -461,14 +461,14 @@ subordinates instMap decl = case decl of
dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)]
dataSubs dd = constrs ++ fields ++ derivs
where
- cons = map unL $ (dd_cons dd)
- constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, conArgDocs c)
+ cons = map unLoc $ (dd_cons dd)
+ constrs = [ (unLoc cname, maybeToList $ fmap unLoc $ con_doc c, conArgDocs c)
| c <- cons, cname <- getConNames c ]
- fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty)
+ fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)
| RecCon flds <- map getConArgs cons
, L _ (ConDeclField _ ns _ doc) <- (unLoc flds)
, L _ n <- ns ]
- derivs = [ (instName, [unL doc], M.empty)
+ derivs = [ (instName, [unLoc doc], M.empty)
| (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $
concatMap (unLoc . deriv_clause_tys . unLoc) $
unLoc $ dd_derivs dd
@@ -585,13 +585,13 @@ sortByLoc = sortBy (comparing getLoc)
-- | Filter out declarations that we don't handle in Haddock
filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterDecls = filter (isHandled . unL . fst)
+filterDecls = filter (isHandled . unLoc . fst)
where
isHandled (ForD _ (ForeignImport {})) = True
isHandled (TyClD {}) = True
isHandled (InstD {}) = True
isHandled (DerivD {}) = True
- isHandled (SigD _ d) = isUserLSig (reL d)
+ isHandled (SigD _ d) = isUserLSig (noLoc d)
isHandled (ValD {}) = True
-- we keep doc declarations to be able to get at named docs
isHandled (DocD {}) = True
@@ -677,7 +677,7 @@ mkExportItems
return [ExportDoc doc]
lookupExport (IEDocNamed _ str, _) = liftErrMsg $
- findNamedDoc str [ unL d | d <- decls ] >>= \case
+ findNamedDoc str [ unLoc d | d <- decls ] >>= \case
Nothing -> return []
Just docStr -> do
doc <- processDocStringParas dflags pkgName gre docStr
@@ -725,13 +725,13 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
return [export]
(ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
- let declNames = getMainDeclBinder (unL decl)
+ let declNames = getMainDeclBinder (unLoc decl)
in case () of
_
-- We should not show a subordinate by itself if any of its
-- parents is also exported. See note [1].
| t `notElem` declNames,
- Just p <- find isExported (parents t $ unL decl) ->
+ Just p <- find isExported (parents t $ unLoc decl) ->
do liftErrMsg $ tell [
"Warning: " ++ moduleString thisMod ++ ": " ++
pretty dflags (nameOccName t) ++ " is exported separately but " ++
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-27 08:11:56 +0000