diff options
Diffstat (limited to 'haddock-api/src/Haddock')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 24 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/GhcUtils.hs | 53 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 18 |
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 " ++ |