diff options
60 files changed, 1896 insertions, 1393 deletions
@@ -1,9 +1,11 @@ /dist/ /haddock-api/dist/ /haddock-library/dist/ +/haddock-test/dist/ /html-test/out/ /hypsrc-test/out/ /latex-test/out/ +/hoogle-test/out/ /doc/haddock /doc/haddock.ps diff --git a/.travis.yml b/.travis.yml index c16b1709..585b0b25 100644 --- a/.travis.yml +++ b/.travis.yml @@ -22,6 +22,8 @@ before_install: - cabal install - cd .. - (cd haddock-api/ && cabal install --only-dependencies --enable-tests && cabal configure --enable-tests && cabal build && cabal test && cabal install) + - (cd haddock-test/ && cabal install --only-dependencies && cabal configure && cabal build && cabal install) script: + - export HADDOCK_PATH="dist/build/haddock/haddock" - cabal configure --enable-tests && cabal build && cabal test @@ -46,25 +46,46 @@ format. Please create issues when you have any problems and pull requests if you have some code. -###### Hacking +##### Hacking -To get started you'll need a latest GHC release installed. Below is an -example setup using cabal sandboxes. +To get started you'll need a latest GHC release installed. + +Clone the repository: ```bash git clone https://github.com/haskell/haddock.git cd haddock - cabal sandbox init - cabal sandbox add-source haddock-library - cabal sandbox add-source haddock-api - # adjust -j to the number of cores you want to use - cabal install -j4 --dependencies-only --enable-tests - cabal configure --enable-tests - cabal build -j4 - # run the test suite - cabal test ``` +and then proceed using your favourite build tool. + +###### Using Cabal sandboxes + +```bash +cabal sandbox init +cabal sandbox add-source haddock-library +cabal sandbox add-source haddock-api +cabal sandbox add-source haddock-test +# adjust -j to the number of cores you want to use +cabal install -j4 --dependencies-only --enable-tests +cabal configure --enable-tests +cabal build -j4 +# run the test suite +export HADDOCK_PATH="dist/build/haddock/haddock" +cabal test +``` + +###### Using Stack + +```bash +stack init +stack install +# run the test suite +export HADDOCK_PATH="$HOME/.local/bin/haddock" +stack test +``` + + If you're a GHC developer and want to update Haddock to work with your changes, you should be working on `ghc-head` branch instead of master. See instructions at @@ -59,9 +59,9 @@ endif .PHONY: install_utils/haddock_data install_utils/haddock_data: $(foreach i,$(sort $(dir $(utils/haddock_dist_DATA_FILES))), \ - $(call make-command,$(call INSTALL_DIR,"$(DESTDIR)$(ghclibdir)/$i"))) + $(call make-command,$(INSTALL_DIR) "$(DESTDIR)$(ghclibdir)/$i")) $(foreach i,$(utils/haddock_dist_DATA_FILES), \ - $(call make-command,$(call INSTALL_DATA,$(INSTALL_OPTS),utils/haddock/haddock-api/resources/$i,"$(DESTDIR)$(ghclibdir)/$(dir $i)"))) + $(call make-command,$(INSTALL_DATA) $(INSTALL_OPTS) utils/haddock/haddock-api/resources/$i "$(DESTDIR)$(ghclibdir)/$(dir $i)")) .PHONY: install_utils/haddock_link install_utils/haddock_link: diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index b4ceb1a0..7835ea50 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -38,7 +38,7 @@ library Haskell2010 build-depends: - base >= 4.3 && < 4.9 + base >= 4.3 && < 4.10 , bytestring , filepath , directory @@ -48,6 +48,7 @@ library , array , xhtml >= 3000.2 && < 3000.3 , Cabal >= 1.10 + , ghc-boot , ghc >= 7.10 && < 7.12 , ghc-paths diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 8f327b09..70cdf8a3 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -121,11 +121,8 @@ handleGhcExceptions = -- error messages propagated as exceptions handleGhcException $ \e -> do hFlush stdout - case e of - PhaseFailed _ code -> exitWith code - _ -> do - print (e :: GhcException) - exitFailure + print (e :: GhcException) + exitFailure ------------------------------------------------------------------------------- @@ -258,8 +255,8 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] pkgMod = ifaceMod (head ifaces) - pkgKey = modulePackageKey pkgMod - pkgStr = Just (packageKeyString pkgKey) + pkgKey = moduleUnitId pkgMod + pkgStr = Just (unitIdString pkgKey) pkgNameVer = modulePackageInfo dflags flags pkgMod (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags @@ -272,7 +269,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do (Map.map SrcExternal extSrcMap) (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ]) - pkgSrcMap = Map.mapKeys modulePackageKey extSrcMap + pkgSrcMap = Map.mapKeys moduleUnitId extSrcMap pkgSrcMap' | Flag_HyperlinkedSource `elem` flags = Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap @@ -356,7 +353,7 @@ modulePackageInfo dflags flags modu = cmdline <|> pkgDb where cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags - pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (modulePackageKey modu) + pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (moduleUnitId modu) ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index f6ad9808..f3749a85 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -21,7 +21,6 @@ import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) -import Bag import GHC import Outputable import NameSet @@ -30,6 +29,8 @@ import Data.Char import Data.List import Data.Maybe import Data.Version + +import System.Directory import System.FilePath import System.IO @@ -48,6 +49,7 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do ["@version " ++ showVersion version | not (null (versionBranch version)) ] ++ concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i] + createDirectoryIfMissing True odir h <- openFile (odir </> filename) WriteMode hSetEncoding h utf8 hPutStr h (unlines contents) @@ -68,7 +70,8 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - f (HsForAllTy a b c d e) = HsForAllTy a b c d (g e) + f (HsForAllTy a e) = HsForAllTy a (g e) + f (HsQualTy a e) = HsQualTy a (g e) f (HsBangTy a b) = HsBangTy a (g b) f (HsAppTy a b) = HsAppTy (g a) (g b) f (HsFunTy a b) = HsFunTy (g a) (g b) @@ -85,14 +88,6 @@ outHsType :: OutputableBndr a => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy -makeExplicit :: HsType a -> HsType a -makeExplicit (HsForAllTy _ a b c d) = HsForAllTy Explicit a b c d -makeExplicit x = x - -makeExplicitL :: LHsType a -> LHsType a -makeExplicitL (L src x) = L src (makeExplicit x) - - dropComment :: String -> String dropComment (' ':'-':'-':' ':_) = [] dropComment (x:xs) = x : dropComment xs @@ -129,8 +124,8 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl f (TyClD d@DataDecl{}) = ppData dflags d subdocs f (TyClD d@SynDecl{}) = ppSynonym dflags d f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs - f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] - f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] + f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)] f (SigD sig) = ppSig dflags sig ++ ppFixities f _ = [] @@ -138,37 +133,35 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl ppExport _ _ = [] ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String] -ppSigWithDoc dflags (TypeSig names sig _) subdocs +ppSigWithDoc dflags (TypeSig names sig) subdocs = concatMap mkDocSig names where mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n) - ++ [mkSig n] - mkSig n = operator (out dflags n) ++ " :: " ++ outHsType dflags typ + ++ [pp_sig dflags names (hsSigWcType sig)] getDoc :: Located Name -> [Documentation Name] getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs) - typ = case unL sig of - HsForAllTy Explicit a b c d -> HsForAllTy Implicit a b c d - HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d - x -> x ppSigWithDoc _ _ _ = [] ppSig :: DynFlags -> Sig Name -> [String] ppSig dflags x = ppSigWithDoc dflags x [] +pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> String +pp_sig dflags names (L _ typ) = + operator prettyNames ++ " :: " ++ outHsType dflags typ + where + prettyNames = intercalate ", " $ map (out dflags) names -- note: does not yet output documentation for class methods ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] -ppClass dflags decl subdocs = (out dflags decl' ++ ppTyFams) : ppMethods +ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods where - decl' = decl - { tcdSigs = [], tcdMeths = emptyBag - , tcdATs = [], tcdATDefs = [] - } - ppMethods = concat . map (ppSig' . unLoc) $ tcdSigs decl - ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext + ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl + ppSig' = flip (ppSigWithDoc dflags) subdocs + + add_ctxt = addClassContext (tcdName decl) (tyClDeclTyVars decl) ppTyFams | null $ tcdATs decl = "" @@ -183,16 +176,6 @@ ppClass dflags decl subdocs = (out dflags decl' ++ ppTyFams) : ppMethods , rbrace ] - addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs - addContext (MinimalSig src sig) = MinimalSig src sig - addContext _ = error "expected TypeSig" - - f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d - f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t) - - context = nlHsTyConApp (tcdName decl) - (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars decl))) - tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name tyFamEqnToSyn tfe = SynDecl { tcdLName = tfe_tycon tfe @@ -239,29 +222,36 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of _ -> [] ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] -ppCtor dflags dat subdocs con - = concatMap (lookupCon dflags subdocs) (con_names con) ++ f (con_details con) +ppCtor dflags dat subdocs con@ConDeclH98 {} + -- AZ:TODO get rid of the concatMap + = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat - [(concatMap (lookupCon dflags subdocs) (cd_fld_names r)) ++ - [out dflags (map unL $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] + [(concatMap (lookupCon dflags subdocs . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++ + [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) + funs = foldr1 (\x y -> reL $ HsFunTy x y) apps = foldl1 (\x y -> reL $ HsAppTy x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) + typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ 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 $ con_names con + name = commaSeparate dflags . map unL $ getConNames con + + resType = apps $ map (reL . HsTyVar . reL) $ + (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] + +ppCtor dflags _dat subdocs con@ConDeclGADT {} + = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f + where + f = [typeSig name (hsib_body $ con_type con)] - resType = case con_res con of - ResTyH98 -> apps $ map (reL . HsTyVar) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] - ResTyGADT _ x -> x + typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) + name = out dflags $ map unL $ getConNames con ppFixity :: DynFlags -> (Name, Fixity) -> [String] diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 5eca973e..e8baae88 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} module Haddock.Backends.Hyperlinker.Ast (enrich) where @@ -56,8 +57,8 @@ variables = where var term = case cast term of (Just (GHC.L sspan (GHC.HsVar name))) -> - pure (sspan, RtkVar name) - (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _))) -> + pure (sspan, RtkVar (GHC.unLoc name)) + (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) -> pure (sspan, RtkVar name) _ -> empty rec term = case cast term of @@ -72,7 +73,7 @@ types = where ty term = case cast term of (Just (GHC.L sspan (GHC.HsTyVar name))) -> - pure (sspan, RtkType name) + pure (sspan, RtkType (GHC.unLoc name)) _ -> empty -- | Obtain details map for identifier bindings. @@ -85,12 +86,12 @@ binds = everything (<|>) (fun `combine` pat `combine` tvar) where fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) -> + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) -> pure (sspan, RtkBind name) _ -> empty pat term = case cast term of (Just (GHC.L sspan (GHC.VarPat name))) -> - pure (sspan, RtkBind name) + pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> [(sspan, RtkVar name)] ++ everything (<|>) rec recs (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) -> @@ -102,7 +103,7 @@ binds = _ -> empty tvar term = case cast term of (Just (GHC.L sspan (GHC.UserTyVar name))) -> - pure (sspan, RtkBind name) + pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> empty @@ -121,12 +122,12 @@ decls (group, _, _, _) = concatMap ($ group) GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty con term = case cast term of (Just cdcl) -> - map decl (GHC.con_names cdcl) ++ everything (<|>) fld cdcl + map decl (GHC.getConNames cdcl) ++ everything (<|>) fld cdcl Nothing -> empty ins term = case cast term of (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst @@ -134,9 +135,10 @@ decls (group, _, _, _) = concatMap ($ group) pure . tyref $ GHC.tfe_tycon eqn _ -> empty fld term = case cast term of - Just field -> map decl $ GHC.cd_fld_names field + Just (field :: GHC.ConDeclField GHC.Name) + -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field Nothing -> empty - sig (GHC.L _ (GHC.TypeSig names _ _)) = map decl names + sig (GHC.L _ (GHC.TypeSig names _)) = map decl names sig _ = [] decl (GHC.L sspan name) = (sspan, RtkDecl name) tyref (GHC.L sspan name) = (sspan, RtkType name) @@ -153,7 +155,8 @@ imports src@(_, imps, _, _) = (Just (GHC.IEVar v)) -> pure $ var v (Just (GHC.IEThingAbs t)) -> pure $ typ t (Just (GHC.IEThingAll t)) -> pure $ typ t - (Just (GHC.IEThingWith t vs)) -> [typ t] ++ map var vs + (Just (GHC.IEThingWith t _ vs _fls)) -> + [typ t] ++ map var 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/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 24779a94..ab6bb41c 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -213,9 +213,9 @@ processExports (e : es) = isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t) _)) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } - | Map.null argDocs = Just (map unLoc lnames, t) + | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing @@ -250,8 +250,8 @@ ppDocGroup lev doc = sec lev <> braces doc declNames :: LHsDecl DocName -> [DocName] declNames (L _ decl) = case decl of TyClD d -> [tcdName d] - SigD (TypeSig lnames _ _) -> map unLoc lnames - SigD (PatSynSig lname _ _ _ _) -> [unLoc lname] + SigD (TypeSig lnames _ ) -> map unLoc lnames + SigD (PatSynSig lname _) -> [unLoc lname] ForD (ForeignImport (L _ n) _ _ _) -> [n] ForD (ForeignExport (L _ n) _ _ _) -> [n] _ -> error "declaration not supported by declNames" @@ -293,10 +293,11 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of -- TyClD d@(TySynonym {}) -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now - TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode - SigD (TypeSig lnames (L _ t) _) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode - SigD (PatSynSig lname qtvs prov req ty) -> - ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode + TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode + SigD (TypeSig lnames t) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) + (hsSigWcType t) unicode + SigD (PatSynSig lname ty) -> + ppLPatSig loc (doc, fnArgsDoc) lname ty unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl" @@ -311,8 +312,8 @@ ppTyFam _ _ _ _ _ = ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX -ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode = - ppFunSig loc doc [name] typ unicode +ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode = + ppFunSig loc doc [name] (hsSigType typ) unicode ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -329,7 +330,9 @@ ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode where - hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars) + hdr = hsep (keyword "type" + : ppDocBinder name + : map ppSymName (tyvarNames ltyvars)) full = hdr <+> char '=' <+> ppLType unicode ltype ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" @@ -340,9 +343,9 @@ ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName +ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocName -> Bool -> LaTeX -ppFunSig loc doc docnames typ unicode = +ppFunSig loc doc docnames (L _ typ) unicode = ppTypeOrFunSig loc docnames typ doc ( ppTypeSig names typ False , hsep . punctuate comma $ map ppSymName names @@ -352,29 +355,17 @@ ppFunSig loc doc docnames typ unicode = names = map getName docnames ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName - -> (HsExplicitFlag, LHsTyVarBndrs DocName) - -> LHsContext DocName -> LHsContext DocName - -> LHsType DocName + -> LHsSigType DocName -> Bool -> LaTeX -ppLPatSig _loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq (L _ ty) unicode +ppLPatSig _loc (doc, _argDocs) (L _ name) ty unicode = declWithDoc pref1 (documentationToLaTeX doc) where pref1 = hsep [ keyword "pattern" , ppDocBinder name , dcolon unicode - , ppLTyVarBndrs expl qtvs unicode - , ctx - , ppType unicode ty + , ppLType unicode (hsSigType ty) ] - ctx = case (ppLContextMaybe lprov unicode, ppLContextMaybe lreq unicode) of - (Nothing, Nothing) -> empty - (Nothing, Just req) -> parens empty <+> darr <+> req <+> darr - (Just prov, Nothing) -> prov <+> darr - (Just prov, Just req) -> prov <+> darr <+> req <+> darr - - darr = darrow unicode - ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) -> Bool -> LaTeX @@ -393,23 +384,15 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs - do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX - do_args n leader (HsForAllTy Explicit _ tvs lctxt ltype) - = decltt leader <-> - decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> - ppLContextNoArrow lctxt unicode) <+> nl $$ - do_largs n (darrow unicode) ltype - - do_args n leader (HsForAllTy Qualified e a lctxt ltype) - = do_args n leader (HsForAllTy Implicit e a lctxt ltype) - do_args n leader (HsForAllTy Implicit _ _ lctxt ltype) - | not (null (unLoc lctxt)) - = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$ - do_largs n (darrow unicode) ltype - -- if we're not showing any 'forall' or class constraints or - -- anything, skip having an empty line for the context. - | otherwise - = do_largs n leader ltype + do_args :: Int -> LaTeX -> HsType DocName -> LaTeX + do_args _n leader (HsForAllTy tvs ltype) + = decltt leader + <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) + <+> ppLType unicode ltype + do_args n leader (HsQualTy lctxt ltype) + = decltt leader + <-> ppLContextNoArrow lctxt unicode <+> nl $$ + do_largs n (darrow unicode) ltype do_args n leader (HsFunTy lt r) = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$ do_largs (n+1) (arrow unicode) r @@ -424,12 +407,12 @@ ppTypeSig nms ty unicode = <+> ppType unicode ty -ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX] -ppTyVars tvs = map ppSymName (tyvarNames tvs) +ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX] +ppTyVars = map (ppSymName . getName . hsLTyVarName) -tyvarNames :: LHsTyVarBndrs DocName -> [Name] -tyvarNames = map getName . hsLTyVarNames +tyvarNames :: LHsQTyVars DocName -> [Name] +tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -478,12 +461,12 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] + -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) - <+> ppAppDocNameNames summ n (tyvarNames $ tvs) + <+> ppAppDocNameNames summ n (tyvarNames tvs) <+> ppFds fds unicode @@ -521,8 +504,8 @@ ppClassDecl instances loc doc subdocs methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig loc doc names typ unicode - | L _ (TypeSig lnames (L _ typ) _) <- lsigs + vcat [ ppFunSig loc doc names (hsSigWcType typ) unicode + | L _ (TypeSig lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -593,14 +576,14 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode where cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + resTy = (unLoc . head) cons body = catMaybes [constrBit, doc >>= documentationToLaTeX] (whereBit, leaders) | null cons = (empty,[]) | otherwise = case resTy of - ResTyGADT _ _ -> (decltt (keyword "where"), repeat empty) + ConDeclGADT{} -> (decltt (keyword "where"), repeat empty) _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) constrBit @@ -614,21 +597,85 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX +ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Bool -> LaTeX ppConstrHdr forall tvs ctxt unicode = (if null tvs then empty else ppForall) <+> (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") where ppForall = case forall of - Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " - Qualified -> empty - Implicit -> empty + True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " + False -> empty ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX -> LConDecl DocName -> LaTeX -ppSideBySideConstr subdocs unicode leader (L _ con) = +ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = + leader <-> + case con_details con of + + PrefixCon args -> + decltt (hsep ((header_ unicode <+> ppOcc) : + map (ppLParendType unicode) args)) + <-> rDoc mbDoc <+> nl + + RecCon (L _ fields) -> + (decltt (header_ unicode <+> ppOcc) + <-> rDoc mbDoc <+> nl) + $$ + doRecordFields fields + + InfixCon arg1 arg2 -> + decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, + ppOcc, + ppLParendType unicode arg2 ]) + <-> rDoc mbDoc <+> nl + + where + doRecordFields fields = + vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) + + + header_ = ppConstrHdr False tyVars context + occ = map (nameOccName . getName . unLoc) $ getConNames con + ppOcc = case occ of + [one] -> ppBinder one + _ -> cat (punctuate comma (map ppBinder occ)) + tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con)) + context = unLoc (fromMaybe (noLoc []) (con_cxt con)) + + -- don't use "con_doc con", in case it's reconstructed from a .hi file, + -- or also because we want Haddock to do the doc-parsing, not GHC. + mbDoc = case getConNames con of + [] -> panic "empty con_names" + (cn:_) -> lookup (unLoc cn) subdocs >>= + fmap _doc . combineDocumentation . fst + +ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) = + leader <-> + doGADTCon (hsib_body $ con_type con) + + where + doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+> + ppLType unicode resTy + ) <-> rDoc mbDoc + + occ = map (nameOccName . getName . unLoc) $ getConNames con + ppOcc = case occ of + [one] -> ppBinder one + _ -> cat (punctuate comma (map ppBinder occ)) + + -- don't use "con_doc con", in case it's reconstructed from a .hi file, + -- or also because we want Haddock to do the doc-parsing, not GHC. + mbDoc = case getConNames con of + [] -> panic "empty con_names" + (cn:_) -> lookup (unLoc cn) subdocs >>= + fmap _doc . combineDocumentation . fst +{- old + +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX + -> LConDecl DocName -> LaTeX +ppSideBySideConstr subdocs unicode leader (L loc con) = leader <-> case con_res con of ResTyH98 -> case con_details con of @@ -662,13 +709,13 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = doRecordFields fields = vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) - doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> hsep [ - ppForAll forall ltvs (con_cxt con) unicode, - ppLType unicode (foldr mkFunTy resTy args) ] + doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> + ppLType unicode (mk_forall $ mk_phi $ + foldr mkFunTy resTy args) ) <-> rDoc mbDoc - header_ = ppConstrHdr forall tyVars context + header_ = ppConstrHdr (con_explicit con) tyVars context occ = map (nameOccName . getName . unLoc) $ con_names con ppOcc = case occ of [one] -> ppBinder one @@ -676,7 +723,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) - forall = con_explicit con + + mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty) + | otherwise = ty + mk_phi ty | null context = ty + | otherwise = L loc (HsQualTy (con_cxt con) ty) + -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. mbDoc = case con_names con of @@ -684,16 +736,16 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = (cn:_) -> lookup (unLoc cn) subdocs >>= fmap _doc . combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) - +-} ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX ppSideBySideField subdocs unicode (ConDeclField names ltype _) = - decltt (cat (punctuate comma (map (ppBinder . nameOccName . getName . unL) names)) + decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation - mbDoc = lookup (unL $ head names) subdocs >>= fmap _doc . combineDocumentation . fst + mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX @@ -792,9 +844,6 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppLContextMaybe :: Located (HsContext DocName) -> Bool -> Maybe LaTeX -ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc - ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX ppContextNoLocsMaybe [] _ = Nothing ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode @@ -824,9 +873,10 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) ------------------------------------------------------------------------------- -ppBang :: HsBang -> LaTeX -ppBang HsNoBang = empty -ppBang _ = char '!' -- Unpacked args is an implementation detail, +ppBang :: HsSrcBang -> LaTeX +ppBang (HsSrcBang _ _ SrcStrict) = char '!' +ppBang (HsSrcBang _ _ SrcLazy) = char '~' +ppBang _ = empty tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX @@ -879,33 +929,22 @@ ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Located (HsContext DocName) -> Bool -> LaTeX -ppForAll expl tvs cxt unicode = ppLTyVarBndrs expl tvs unicode <+> ppLContext cxt unicode - -ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Bool -> LaTeX -ppLTyVarBndrs expl tvs unicode - | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) <> dot - | otherwise = empty - where - show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} - ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX -ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode + = maybeParen ctxt_prec pREC_FUN $ + sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot + , ppr_mono_lty pREC_TOP ty unicode ] +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode = maybeParen ctxt_prec pREC_FUN $ - hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode] - where ctxt' = case extra of - Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt - Nothing -> ctxt + sep [ ppLContext ctxt unicode + , ppr_mono_lty pREC_TOP ty unicode ] ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty -ppr_mono_ty _ (HsTyVar name) _ = ppDocName name +ppr_mono_ty _ (HsTyVar (L _ name)) _ = 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 _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) @@ -913,12 +952,10 @@ ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" 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 _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys -ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode = maybeParen ctxt_prec pREC_OP $ @@ -928,7 +965,7 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] -ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode where @@ -942,12 +979,14 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode = ppr_mono_lty ctxt_prec ty unicode -ppr_mono_ty _ HsWildcardTy _ = char '_' +ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsNamedWildcardTy name) _ = ppDocName name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ = ppDocName name ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u +ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy" + ppr_tylit :: HsTyLit -> Bool -> LaTeX ppr_tylit (HsNumTy _ n) _ = integer n diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 819974a2..660bbe90 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -304,7 +304,7 @@ mkNode qual ss p (Node s leaf pkg srcPkg short ts) = htmlModule = thespan ! modAttrs << (cBtn +++ if leaf - then ppModule (mkModule (stringToPackageKey (fromMaybe "" pkg)) + then ppModule (mkModule (stringToUnitId (fromMaybe "" pkg)) (mkModuleName mdl)) else toHtml s ) @@ -586,7 +586,7 @@ processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 (DataDecl{}) -> [keyword "data" <+> b] (SynDecl{}) -> [keyword "type" <+> b] (ClassDecl {}) -> [keyword "class" <+> b] - SigD (TypeSig lnames (L _ _) _) -> + SigD (TypeSig lnames _) -> map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 6fed2e1d..f8599355 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -38,18 +38,20 @@ import GHC import GHC.Exts import Name import BooleanFormula +import RdrName ( rdrNameOcc ) ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of - TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual - TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual - TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual - TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual - SigD (TypeSig lnames lty _) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual - SigD (PatSynSig lname qtvs prov req ty) -> - ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual + TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual + TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual + TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual + TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual + SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames + (hsSigWcType lty) fixities splice unicode qual + SigD (PatSynSig lname ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname + ty fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual InstD _ -> noHtml _ -> error "declaration not supported by ppDecl" @@ -59,26 +61,23 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode qual = - ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities + ppFunSig summary links loc doc (map unLoc lnames) lty fixities splice unicode qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [DocName] -> HsType DocName -> [(DocName, Fixity)] -> + [DocName] -> LHsType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppFunSig summary links loc doc docnames typ fixities splice unicode qual = - ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ) + ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) splice unicode qual where - pp_typ = ppType unicode qual typ + pp_typ = ppLType unicode qual typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - Located DocName -> - (HsExplicitFlag, LHsTyVarBndrs DocName) -> - LHsContext DocName -> LHsContext DocName -> - LHsType DocName -> + Located DocName -> LHsSigType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual +ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual | summary = pref1 | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual) +++ docSection Nothing qual doc @@ -86,18 +85,9 @@ ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq t pref1 = hsep [ keyword "pattern" , ppBinder summary occname , dcolon unicode - , ppLTyVarBndrs expl qtvs unicode qual - , cxt - , ppLType unicode qual typ + , ppLType unicode qual (hsSigType typ) ] - cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of - (Nothing, Nothing) -> noHtml - (Nothing, Just req) -> parens noHtml <+> darr <+> req <+> darr - (Just prov, Nothing) -> prov <+> darr - (Just prov, Just req) -> prov <+> darr <+> req <+> darr - - darr = darrow unicode occname = nameOccName . getName $ name ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> @@ -131,22 +121,29 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) argDoc n = Map.lookup n argDocs do_largs n leader (L _ t) = do_args n leader t + do_args :: Int -> Html -> HsType DocName -> [SubDecl] - do_args n leader (HsForAllTy _ _ tvs lctxt ltype) - = case unLoc lctxt of - [] -> do_largs n leader' ltype - _ -> (leader' <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) - : do_largs n (darrow unicode) ltype - where leader' = leader <+> ppForAll tvs unicode qual + do_args n leader (HsForAllTy tvs ltype) + = do_largs n leader' ltype + where + leader' = leader <+> ppForAll tvs unicode qual + + do_args n leader (HsQualTy lctxt ltype) + | null (unLoc lctxt) + = do_largs n leader ltype + | otherwise + = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) + : do_largs n (darrow unicode) ltype + do_args n leader (HsFunTy lt r) = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t = [(leader <+> ppType unicode qual t, argDoc n, [])] -ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html +ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = - case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- hsQTvBndrs tvs] of + case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of [] -> noHtml ts -> forallSymbol unicode <+> hsep ts +++ dot where ppKTv n k = parens $ @@ -174,20 +171,19 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge rightEdge = thespan ! [theclass "rightedge"] << noHtml -ppTyVars :: LHsTyVarBndrs DocName -> [Html] -ppTyVars tvs = map ppTyName (tyvarNames tvs) - +ppTyVars :: [LHsTyVarBndr DocName] -> [Html] +ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs -tyvarNames :: LHsTyVarBndrs DocName -> [Name] -tyvarNames = map getName . hsLTyVarNames +tyvarNames :: LHsQTyVars DocName -> [Name] +tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities +ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities splice unicode qual - = ppFunSig summary links loc doc [name] typ fixities splice unicode qual + = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -202,7 +198,8 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) splice unicode qual where - hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) + hdr = hsep ([keyword "type", ppBinder summary occ] + ++ ppTyVars (hsQTvExplicit ltyvars)) full = hdr <+> equals <+> ppLType unicode qual ltype occ = nameOccName . getName $ name fixs @@ -248,28 +245,48 @@ ppFamilyInfo assoc DataFamily ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family" -ppFamilyKind :: Unicode -> Qualification -> Maybe (LHsKind DocName) -> Html -ppFamilyKind unicode qual (Just kind) = - dcolon unicode <+> ppLKind unicode qual kind -ppFamilyKind _ _ Nothing = noHtml - - ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Unicode -> Qualification -> Html ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info - , fdKindSig = mkind }) + , fdResultSig = L _ result + , fdInjectivityAnn = injectivity }) unicode qual = - ppFamilyInfo associated info <+> - ppFamDeclBinderWithVars summary d <+> - ppFamilyKind unicode qual mkind - + (case info of + OpenTypeFamily + | associated -> keyword "type" + | otherwise -> keyword "type family" + DataFamily + | associated -> keyword "data" + | otherwise -> keyword "data family" + ClosedTypeFamily _ + -> keyword "type family" + ) <+> + + ppFamDeclBinderWithVars summary d <+> + ppResultSig result unicode qual <+> + + (case injectivity of + Nothing -> noHtml + Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn + ) + +ppResultSig :: FamilyResultSig DocName -> Unicode -> Qualification -> Html +ppResultSig result unicode qual = case result of + NoSig -> noHtml + KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind + TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName -> Html ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) = ppFamilyInfo True pfdInfo <+> ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+> - ppFamilyKind unicode qual pfdKindSig + ppResultSig (unLoc pfdKindSig) unicode qual + +ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html +ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) = + char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+> + hsep (map (ppLDocName qual Raw) rhs) ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> @@ -287,16 +304,16 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual instancesBit - | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl + | FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl , not summary - = subEquations qual $ map (ppTyFamEqn . unLoc) eqns + = subEquations qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns | otherwise = ppInstances links (OriginFamily docname) instances splice unicode qual -- Individual equation of a closed type family ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs - , tfe_pats = HsWB { hswb_cts = ts }} + , tfe_pats = HsIB { hsib_body = ts }} = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual (unLoc rhs) , Nothing, [] ) @@ -381,10 +398,6 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc - -ppLContextMaybe :: Located (HsContext DocName) -> Unicode -> Qualification -> Maybe Html -ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc - ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html ppContextNoArrow cxt unicode qual = fromMaybe noHtml $ ppContextNoLocsMaybe (map unLoc cxt) unicode qual @@ -415,7 +428,7 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] + -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" @@ -438,7 +451,7 @@ ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc subdocs splice unicode qual = - if not (any isVanillaLSig sigs) && null ats + if not (any isUserLSig sigs) && null ats then (if summary then id else topDeclElem links loc splice [nm]) hdr else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") +++ shortSubDecls False @@ -448,8 +461,9 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names typ [] splice unicode qual - | L _ (TypeSig lnames (L _ typ) _) <- sigs + [ ppFunSig summary links loc doc names (hsSigWcType typ) + [] splice unicode qual + | L _ (TypeSig lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -478,7 +492,7 @@ ppClassDecl summary links instances fixities loc d subdocs sigs = map unLoc lsigs classheader - | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) + | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) -- Only the fixity relevant to the class header @@ -495,8 +509,9 @@ ppClassDecl summary links instances fixities loc d subdocs doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual - | TypeSig lnames (L _ typ) _ <- sigs + methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ) + subfixs splice unicode qual + | L _ (ClassOpSig _ lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs subfixs = [ f | n <- names , f@(n',_) <- fixities @@ -506,15 +521,15 @@ ppClassDecl summary links instances fixities loc d subdocs -- there are different subdocs for different names in a single -- type signature? - minimalBit = case [ s | MinimalSig _ s <- sigs ] of + minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method - And xs : _ | sort [getName n | Var (L _ n) <- xs] == - sort [getName n | TypeSig ns _ _ <- sigs, L _ n <- ns] + And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == + sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | TypeSig ns _ _ <- sigs, L _ n' <- ns] + [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -524,9 +539,10 @@ ppClassDecl summary links instances fixities loc d subdocs _ -> noHtml ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n - ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs - ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs + ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True . unLoc) fs + ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False . unLoc) fs where wrap | p = parens | otherwise = id + ppMinimal p (Parens x) = ppMinimal p (unLoc x) instancesBit = ppInstances links (OriginClass nm) instances splice unicode qual @@ -608,9 +624,12 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification -> [Sig DocName] -> [Html] ppInstanceSigs links splice unicode qual sigs = do - TypeSig lnames (L loc typ) _ <- sigs + TypeSig lnames typ <- sigs let names = map unLoc lnames - return $ ppSimpleSig links splice unicode qual loc names typ + L loc rtyp = get_type typ + return $ ppSimpleSig links splice unicode qual loc names rtyp + where + get_type = hswc_body . hsib_body lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 @@ -642,11 +661,11 @@ ppShortDataDecl summary dataInst dataDecl unicode qual | [] <- cons = dataHeader - | [lcon] <- cons, ResTyH98 <- resTy, + | [lcon] <- cons, isH98, (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot - | ResTyH98 <- resTy = dataHeader + | isH98 = dataHeader +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons) | otherwise = (dataHeader <+> keyword "where") @@ -660,7 +679,9 @@ ppShortDataDecl summary dataInst dataDecl unicode qual doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + isH98 = case unLoc (head cons) of + ConDeclH98 {} -> True + ConDeclGADT{} -> False ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> @@ -676,7 +697,9 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl where docname = tcdName dataDecl cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + isH98 = case unLoc (head cons) of + ConDeclH98 {} -> True + ConDeclGADT{} -> False header_ = topDeclElem links loc splice [docname] $ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix @@ -685,15 +708,13 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl whereBit | null cons = noHtml - | otherwise = case resTy of - ResTyGADT _ _ -> keyword "where" - _ -> noHtml + | otherwise = if isH98 then noHtml else keyword "where" constrBit = subConstructors qual [ ppSideBySideConstr subdocs subfixs unicode qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) - (map unLoc (con_names (unLoc c)))) fixities + (map unLoc (getConNames (unLoc c)))) fixities ] instancesBit = ppInstances links (OriginData docname) instances @@ -710,8 +731,8 @@ ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot -- returns three pieces: header, body, footer so that header & footer can be -- incorporated into the declaration ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html) -ppShortConstrParts summary dataInst con unicode qual = case con_res con of - ResTyH98 -> case con_details con of +ppShortConstrParts summary dataInst con unicode qual = case con of + ConDeclH98{} -> case con_details con of PrefixCon args -> (header_ unicode qual +++ hsep (ppOcc : map (ppLParendType unicode qual) args), noHtml, noHtml) @@ -724,28 +745,15 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of ppOccInfix, ppLParendType unicode qual arg2], noHtml, noHtml) - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml) - -- display GADT records with the new syntax, - -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b) - -- (except each field gets its own line in docs, to match - -- non-GADT records) - RecCon (L _ fields) -> (ppOcc <+> dcolon unicode <+> - ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{', - doRecordFields fields, - char '}' <+> arrow unicode <+> ppLType unicode qual resTy) - InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) + ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml) where + resTy = hsib_body (con_type con) + doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields)) - doGADTCon args resTy = ppOcc <+> dcolon unicode <+> hsep [ - ppForAllCon forall_ ltvs lcontext unicode qual, - ppLType unicode qual (foldr mkFunTy resTy args) ] header_ = ppConstrHdr forall_ tyVars context - occ = map (nameOccName . getName . unLoc) $ con_names con + occ = map (nameOccName . getName . unLoc) $ getConNames con ppOcc = case occ of [one] -> ppBinder summary one @@ -755,35 +763,34 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of [one] -> ppBinderInfix summary one _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) - ltvs = con_qvars con + ltvs = fromMaybe (HsQTvs PlaceHolder []) (con_qvars con) tyVars = tyvarNames ltvs - lcontext = con_cxt con - context = unLoc (con_cxt con) - forall_ = con_explicit con - mkFunTy a b = noLoc (HsFunTy a b) + lcontext = fromMaybe (noLoc []) (con_cxt con) + context = unLoc lcontext + forall_ = False -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode +ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Unicode -> Qualification -> Html ppConstrHdr forall_ tvs ctxt unicode qual = (if null tvs then noHtml else ppForall) +++ - (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual - <+> darrow unicode +++ toHtml " ") + (if null ctxt then noHtml + else ppContextNoArrow ctxt unicode qual + <+> darrow unicode +++ toHtml " ") where - ppForall = case forall_ of - Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". " - Qualified -> noHtml - Implicit -> noHtml - + ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) + <+> toHtml ". " + | otherwise = noHtml ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> Unicode -> Qualification -> LConDecl DocName -> SubDecl -ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) +ppSideBySideConstr subdocs fixities unicode qual (L _ con) + = (decl, mbDoc, fieldPart) where - decl = case con_res con of - ResTyH98 -> case con_details con of + decl = case con of + ConDeclH98{} -> case con_details con of PrefixCon args -> hsep ((header_ +++ ppOcc) : map (ppLParendType unicode qual) args) @@ -797,28 +804,26 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field ppLParendType unicode qual arg2] <+> fixity - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could also use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> doGADTCon args resTy - cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + ConDeclGADT{} -> doGADTCon resTy + + resTy = hsib_body (con_type con) - fieldPart = case con_details con of + fieldPart = case getConDetails con of RecCon (L _ fields) -> [doRecordFields fields] _ -> [] doRecordFields fields = subFields qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) - doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html - doGADTCon args resTy = ppOcc <+> dcolon unicode - <+> hsep [ppForAllCon forall_ ltvs (con_cxt con) unicode qual, - ppLType unicode qual (foldr mkFunTy resTy args) ] + + doGADTCon :: Located (HsType DocName) -> Html + doGADTCon ty = ppOcc <+> dcolon unicode + -- ++AZ++ make this prepend "{..}" when it is a record style GADT + <+> ppLType unicode qual ty <+> fixity fixity = ppFixities fixities qual header_ = ppConstrHdr forall_ tyVars context unicode qual - occ = map (nameOccName . getName . unLoc) $ con_names con + occ = map (nameOccName . getName . unLoc) $ getConNames con ppOcc = case occ of [one] -> ppBinder False one @@ -828,32 +833,30 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field [one] -> ppBinderInfix False one _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) - ltvs = con_qvars con - tyVars = tyvarNames (con_qvars con) - context = unLoc (con_cxt con) - forall_ = con_explicit con + tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con)) + context = unLoc (fromMaybe (noLoc []) (con_cxt con)) + forall_ = False -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ head $ con_names con) subdocs >>= + mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>= combineDocumentation . fst - mkFunTy a b = noLoc (HsFunTy a b) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocName -> SubDecl ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = - (hsep (punctuate comma (map ((ppBinder False) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, + (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, mbDoc, []) where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation - mbDoc = lookup (unL $ head names) subdocs >>= combineDocumentation . fst + mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html ppShortField summary unicode qual (ConDeclField names ltype _) - = hsep (punctuate comma (map ((ppBinder summary) . nameOccName . getName . unL) names)) + = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype @@ -883,10 +886,10 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- -ppBang :: HsBang -> Html -ppBang HsNoBang = noHtml -ppBang _ = toHtml "!" -- Unpacked args is an implementation detail, - -- so we just show the strictness annotation +ppBang :: HsSrcBang -> Html +ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!" +ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~" +ppBang _ = noHtml tupleParens :: HsTupleSort -> [Html] -> Html @@ -932,52 +935,42 @@ ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual +ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html +ppHsTyVarBndr _ qual (UserTyVar (L _ name)) = + ppDocName qual Raw False name +ppHsTyVarBndr unicode qual (KindedTyVar name kind) = + parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + ppLKind unicode qual kind) + ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocName -> Html ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual --- Drop top-level for-all type variables in user style --- since they are implicit in Haskell - -ppForAllCon :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Located (HsContext DocName) -> Unicode -> Qualification -> Html -ppForAllCon expl tvs cxt unicode qual = - forall_part <+> ppLContext cxt unicode qual - where - forall_part = ppLTyVarBndrs expl tvs unicode qual - -ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Unicode -> Qualification - -> Html -ppLTyVarBndrs expl tvs unicode _qual - | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot - | otherwise = noHtml - where - show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} - +ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html +ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html -ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual - = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual - <+> ppr_mono_lty pREC_TOP ty unicode qual - where ctxt' = case extra of - Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt - Nothing -> ctxt +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual + = maybeParen ctxt_prec pREC_FUN $ + ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual + +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual + = maybeParen ctxt_prec pREC_FUN $ + ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual -- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar 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 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 _ (HsKindSig ty kind) u q = @@ -987,14 +980,14 @@ ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TO ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q = maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" -ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" +ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}" + -- Can now legally occur in ConDeclGADT, the output here is to provide a + -- 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 _ (HsExplicitTupleTy _ tys) u q = - promoQuote $ parenList $ map (ppLType u q) tys -ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy" +ppr_mono_ty _ (HsExplicitListTy _ tys) u q = promoQuote $ 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" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual = maybeParen ctxt_prec pREC_CTX $ @@ -1004,7 +997,7 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] -ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual where @@ -1022,9 +1015,9 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual = ppr_mono_lty ctxt_prec ty unicode qual -ppr_mono_ty _ HsWildcardTy _ _ = char '_' +ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' -ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ q = ppDocName q Prefix True name ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 3c132497..98df09fe 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -281,7 +281,7 @@ links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice (Documented n m -- TODO: do something about type instances. They will point to -- the module defining the type family, which is wrong. origMod = nameModule n - origPkg = modulePackageKey origMod + origPkg = moduleUnitId origMod fname = case loc of RealSrcSpan l -> unpackFS (srcSpanFile l) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs index 3d1db887..d1561791 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs @@ -23,7 +23,7 @@ import GHC -- the base, module and entity URLs for the source code and wiki links. -type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageKey FilePath, Map PackageKey FilePath) +type SourceURLs = (Maybe FilePath, Maybe FilePath, Map UnitId FilePath, Map UnitId FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index c9664652..bc293731 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -22,22 +22,22 @@ import Class import CoAxiom import ConLike import Data.Either (lefts, rights) -import Data.List( partition ) import DataCon import FamInstEnv import HsSyn -import Kind ( splitKindFunTys, synTyConResKind, isKind ) import Name +import RdrName ( mkVarUnqual ) import PatSyn -import PrelNames (ipClassName) -import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) +import SrcLoc ( Located, noLoc, unLoc ) import TcType ( tcSplitSigmaTy ) import TyCon -import Type (isStrLitTy, mkFunTys) -import TypeRep +import Type +import TyCoRep import TysPrim ( alphaTyVars ) -import TysWiredIn ( listTyConName, eqTyCon ) +import TysWiredIn ( listTyConName, ipTyCon ) +import PrelNames ( hasKey, eqTyConKey ) import Unique ( getUnique ) +import Util ( filterByList, filterOut ) import Var import Haddock.Types @@ -78,7 +78,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 . fmap noLoc $ classMinimalDef cl) : + , tcdSigs = noLoc (MinimalSig mempty . noLoc . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature @@ -96,17 +96,11 @@ tyThingToLHsDecl t = case t of -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc] - (synifyType ImplicitizeForAll (dataConUserType dc)) []) + (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps - qtvs = univ_tvs ++ ex_tvs - ty = mkFunTys arg_tys res_ty - in allOK . SigD $ PatSynSig (synifyName ps) - (Implicit, synifyTyVars qtvs) - (synifyCtx req_theta) - (synifyCtx prov_theta) - (synifyType WithinType ty) + allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType + (patSynType ps)) where withErrs e x = return (e, x) allOK x = return (mempty, x) @@ -116,12 +110,9 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) = let name = synifyName tc typats = map (synifyType WithinType) args hs_rhs = synifyType WithinType rhs - (kvs, tvs) = partition isKindVar tkvs in TyFamEqn { tfe_tycon = name - , tfe_pats = HsWB { hswb_cts = typats - , hswb_kvs = map tyVarName kvs - , hswb_tvs = map tyVarName tvs - , hswb_wcs = [] } + , tfe_pats = HsIB { hsib_body = typats + , hsib_vars = map tyVarName tkvs } , tfe_rhs = hs_rhs } synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) @@ -132,7 +123,7 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch , tfid_fvs = placeHolderNamesTc })) - | Just ax' <- isClosedSynFamilyTyCon_maybe tc + | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error = synifyTyCon (Just ax) tc >>= return . TyClD @@ -141,7 +132,7 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) -- | Turn type constructors into type class declarations synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name) -synifyTyCon coax tc +synifyTyCon _coax tc | isFunTyCon tc || isPrimTyCon tc = return $ DataDecl { tcdLName = synifyName tc @@ -149,8 +140,8 @@ synifyTyCon coax tc let mk_hs_tv realKind fakeTyVar = noLoc $ KindedTyVar (noLoc (getName fakeTyVar)) (synifyKindSig realKind) - in HsQTvs { hsq_kvs = [] -- No kind polymorphism - , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) + in HsQTvs { hsq_implicit = [] -- No kind polymorphism + , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind * } @@ -164,33 +155,38 @@ synifyTyCon coax tc , dd_derivs = Nothing } , tcdFVs = placeHolderNamesTc } - | isTypeFamilyTyCon tc - = case famTyConFlav_maybe tc of - Just rhs -> - let info = case rhs of - OpenSynFamilyTyCon -> return OpenTypeFamily - ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) -> - return $ ClosedTypeFamily - (brListMap (noLoc . synifyAxBranch tc) branches) - BuiltInSynFamTyCon {} -> return $ ClosedTypeFamily [] - AbstractClosedSynFamilyTyCon {} -> return $ ClosedTypeFamily [] - in info >>= \i -> - return (FamDecl - (FamilyDecl { fdInfo = i - , fdLName = synifyName tc - , fdTyVars = synifyTyVars (tyConTyVars tc) - , fdKindSig = - Just (synifyKindSig (synTyConResKind tc)) - })) - Nothing -> Left "synifyTyCon: impossible open type synonym?" - - | isDataFamilyTyCon tc - = --(why no "isOpenAlgTyCon"?) - case algTyConRhs tc of - DataFamilyTyCon -> return $ - FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) - Nothing) --always kind '*' - _ -> Left "synifyTyCon: impossible open data type?" +synifyTyCon _coax tc + | Just flav <- famTyConFlav_maybe tc + = case flav of + -- Type families + OpenSynFamilyTyCon -> mkFamDecl OpenTypeFamily + ClosedSynFamilyTyCon mb + | Just (CoAxiom { co_ax_branches = branches }) <- mb + -> mkFamDecl $ ClosedTypeFamily $ Just + $ map (noLoc . synifyAxBranch tc) (fromBranches branches) + | otherwise + -> mkFamDecl $ ClosedTypeFamily $ Just [] + BuiltInSynFamTyCon {} + -> mkFamDecl $ ClosedTypeFamily $ Just [] + AbstractClosedSynFamilyTyCon {} + -> mkFamDecl $ ClosedTypeFamily Nothing + DataFamilyTyCon {} + -> mkFamDecl DataFamily + where + resultVar = famTcResVar tc + mkFamDecl i = return $ FamDecl $ + FamilyDecl { fdInfo = i + , fdLName = synifyName tc + , fdTyVars = synifyTyVars (tyConTyVars tc) + , fdResultSig = + synifyFamilyResultSig resultVar tyConResKind + , fdInjectivityAnn = + synifyInjectivityAnn resultVar (tyConTyVars tc) + (familyTyConInjectivityInfo tc) + } + tyConResKind = piResultTys (tyConKind tc) (mkTyVarTys (tyConTyVars tc)) + +synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConTyVars tc) @@ -240,6 +236,20 @@ synifyTyCon coax tc , tcdFVs = placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs +synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity + -> Maybe (LInjectivityAnn Name) +synifyInjectivityAnn Nothing _ _ = Nothing +synifyInjectivityAnn _ _ NotInjective = Nothing +synifyInjectivityAnn (Just lhs) tvs (Injective inj) = + let rhs = map (noLoc . tyVarName) (filterByList inj tvs) + in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs + +synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig Name +synifyFamilyResultSig Nothing kind = + noLoc $ KindSig (synifyKindSig kind) +synifyFamilyResultSig (Just name) kind = + noLoc $ TyVarSig (noLoc $ KindedTyVar (noLoc name) (synifyKindSig kind)) + -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its -- result-type. @@ -263,21 +273,18 @@ synifyDataCon use_gadt_syntax dc = -- skip any EqTheta, use 'orig'inal syntax ctx = synifyCtx theta - linear_tys = zipWith (\ty bang -> - let tySyn = synifyType WithinType ty - src_bang = case bang of - HsUnpack {} -> HsSrcBang Nothing (Just True) True - HsStrict -> HsSrcBang Nothing (Just False) True - _ -> bang - in case src_bang of - HsNoBang -> tySyn - _ -> noLoc $ HsBangTy bang tySyn - -- HsNoBang never appears, it's implied instead. - ) - arg_tys (dataConSrcBangs dc) - field_tys = zipWith (\field synTy -> noLoc $ ConDeclField - [synifyName field] synTy Nothing) - (dataConFieldLabels dc) linear_tys + linear_tys = + zipWith (\ty bang -> + let tySyn = synifyType WithinType ty + in case bang of + (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn + bang' -> noLoc $ HsBangTy bang' tySyn) + arg_tys (dataConSrcBangs dc) + + field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys + con_decl_field fl synTy = noLoc $ + ConDeclField [noLoc $ FieldOcc (mkVarUnqual $ flLabel fl) (flSelector fl)] synTy + Nothing hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" (True,False) -> return $ RecCon (noLoc field_tys) @@ -285,39 +292,45 @@ synifyDataCon use_gadt_syntax dc = (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?" - hs_res_ty = if use_gadt_syntax - then ResTyGADT noSrcSpan (synifyType WithinType res_ty) - else ResTyH98 + gadt_ty = HsIB [] (synifyType WithinType res_ty) -- finally we get synifyDataCon's result! in hs_arg_tys >>= - \hat -> return . noLoc $ ConDecl [name] Implicit -- we don't know nor care - qvars ctx hat hs_res_ty Nothing - -- we don't want any "deprecated GADT syntax" warnings! - False + \hat -> + if use_gadt_syntax + then return $ noLoc $ + ConDeclGADT { con_names = [name] + , con_type = gadt_ty + , con_doc = Nothing } + else return $ noLoc $ + ConDeclH98 { con_name = name + , con_qvars = Just qvars + , con_cxt = Just ctx + , con_details = hat + , con_doc = Nothing } synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName synifyIdSig :: SynifyTypeState -> Id -> Sig Name -synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) [] +synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) synifyCtx :: [PredType] -> LHsContext Name synifyCtx = noLoc . map (synifyType WithinType) -synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name -synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs - , hsq_tvs = map synifyTyVar tvs } +synifyTyVars :: [TyVar] -> LHsQTyVars Name +synifyTyVars ktvs = HsQTvs { hsq_implicit = [] + , hsq_explicit = map synifyTyVar ktvs } + +synifyTyVar :: TyVar -> LHsTyVarBndr Name +synifyTyVar tv + | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name)) + | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) where - (kvs, tvs) = partition isKindVar ktvs - synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar name) - | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) - where - kind = tyVarKind tv - name = getName tv + kind = tyVarKind tv + name = getName tv --states of what to do with foralls: data SynifyTypeState @@ -335,12 +348,22 @@ data SynifyTypeState -- the defining class gets to quantify all its functions for free! +synifySigType :: SynifyTypeState -> Type -> LHsSigType Name +-- The empty binders is a bit suspicious; +-- what if the type has free variables? +synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty) + +synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name +-- Ditto (see synifySigType) +synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty)) + synifyType :: SynifyTypeState -> Type -> LHsType Name -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) +synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv) synifyType _ (TyConApp tc tys) -- Use non-prefix tuple syntax where possible, because it looks nicer. - | isTupleTyCon tc, tyConArity tc == length tys = - noLoc $ HsTupleTy (case tupleTyConSort tc of + | Just sort <- tyConTuple_maybe tc + , tyConArity tc == length tys + = noLoc $ HsTupleTy (case sort of BoxedTuple -> HsBoxedTuple ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) @@ -349,40 +372,42 @@ synifyType _ (TyConApp tc tys) | getName tc == listTyConName, [ty] <- tys = noLoc $ HsListTy (synifyType WithinType ty) -- ditto for implicit parameter tycons - | tyConName tc == ipClassName + | tc == ipTyCon , [name, ty] <- tys , Just x <- isStrLitTy name = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) -- and equalities - | tc == eqTyCon + | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) -- Most TyCons: | otherwise = foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) - (noLoc $ HsTyVar (getName tc)) - (map (synifyType WithinType) tys) + (noLoc $ HsTyVar $ noLoc (getName tc)) + (map (synifyType WithinType) $ + filterOut isCoercionTy tys) +synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 synifyType _ (AppTy t1 t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 in noLoc $ HsAppTy s1 s2 -synifyType _ (FunTy t1 t2) = let +synifyType _ (ForAllTy (Anon t1) t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 in noLoc $ HsFunTy s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = let (tvs, ctx, tau) = tcSplitSigmaTy forallty - sTvs = synifyTyVars tvs - sCtx = synifyCtx ctx - sTau = synifyType WithinType tau - mkHsForAllTy forallPlicitness = - noLoc $ HsForAllTy forallPlicitness Nothing sTvs sCtx sTau + sPhi = HsQualTy { hst_ctxt = synifyCtx ctx + , hst_body = synifyType WithinType tau } in case s of DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau - WithinType -> mkHsForAllTy Explicit - ImplicitizeForAll -> mkHsForAllTy Implicit + WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs + , hst_body = noLoc sPhi } + ImplicitizeForAll -> noLoc sPhi synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t +synifyType s (CastTy t _) = synifyType s t +synifyType _ (CoercionTy {}) = error "synifyType:Coercion" synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy mempty n @@ -406,7 +431,7 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead } } where - (ks,ts) = break (not . isKind) types + (ks,ts) = partitionInvisibles (classTyCon cls) id types synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification -- Convert a family instance, this could be a type family or data family @@ -425,5 +450,5 @@ synifyFamInst fi opaque = do return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi ityp (DataFamilyInst c) = DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c - (ks,ts) = break (not . isKind) $ fi_tys fi + (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi synifyTypes = map (unLoc. synifyType WithinType) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index ce4ca38a..4e5e008b 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -68,7 +68,7 @@ getMainDeclBinder _ = [] -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap. getInstLoc :: InstDecl name -> SrcSpan -getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l +getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l getInstLoc (TyFamInstD (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances @@ -91,10 +91,14 @@ filterSigNames p (FixSig (FixitySig ns ty)) = [] -> Nothing filtered -> Just (FixSig (FixitySig filtered ty)) filterSigNames _ orig@(MinimalSig _ _) = Just orig -filterSigNames p (TypeSig ns ty nwcs) = +filterSigNames p (TypeSig ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (TypeSig filtered ty nwcs) + filtered -> Just (TypeSig filtered ty) +filterSigNames p (ClassOpSig is_default ns ty) = + case filter (p . unLoc) ns of + [] -> Nothing + filtered -> Just (ClassOpSig is_default filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name @@ -105,13 +109,19 @@ sigName :: LSig name -> [name] sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [name] -sigNameNoLoc (TypeSig ns _ _) = map unLoc ns -sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n] -sigNameNoLoc (SpecSig n _ _) = [unLoc n] -sigNameNoLoc (InlineSig n _) = [unLoc n] +sigNameNoLoc (TypeSig ns _) = map unLoc ns +sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns +sigNameNoLoc (PatSynSig n _) = [unLoc n] +sigNameNoLoc (SpecSig n _ _) = [unLoc n] +sigNameNoLoc (InlineSig n _) = [unLoc n] sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns sigNameNoLoc _ = [] +-- | Was this signature given by the user? +isUserLSig :: LSig name -> Bool +isUserLSig (L _(TypeSig {})) = True +isUserLSig (L _(ClassOpSig {})) = True +isUserLSig _ = False isTyClD :: HsDecl a -> Bool isTyClD (TyClD _) = True @@ -187,17 +197,18 @@ class Parent a where instance Parent (ConDecl Name) where children con = - case con_details con of - RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields) + case getConDetails con of + RecCon fields -> map (selectorFieldOcc . unL) $ + concatMap (cd_fld_names . unL) (unL fields) _ -> [] instance Parent (TyClDecl Name) where children d - | isDataDecl d = map unL $ concatMap (con_names . unL) + | isDataDecl d = map unL $ concatMap (getConNames . unL) $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = map (unL . fdLName . unL) (tcdATs d) ++ - [ unL n | L _ (TypeSig ns _ _) <- tcdSigs d, n <- ns ] + [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] | otherwise = [] @@ -207,7 +218,7 @@ family = getName &&& children familyConDecl :: ConDecl Name -> [(Name, [Name])] -familyConDecl d = zip (map unL (con_names d)) (repeat $ children d) +familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d) -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively. diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 8b04d76b..62b0aea9 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -239,6 +239,6 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) -------------------------------------------------------------------------------- -withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a +withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a withTempDir dir = gbracket_ (liftIO $ createDirectory dir) (liftIO $ removeDirectoryRecursive dir) diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 5adee457..20971071 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -22,6 +22,7 @@ import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) import Data.Function (on) +import Data.Maybe ( maybeToList, mapMaybe ) import qualified Data.Map as Map import qualified Data.Set as Set @@ -32,7 +33,6 @@ import FamInstEnv import FastString import GHC import GhcMonad (withSession) -import Id import InstEnv import MonadUtils (liftIO) import Name @@ -40,9 +40,8 @@ import Outputable (text, sep, (<+>)) import PrelNames import SrcLoc import TcRnDriver (tcRnGetInfo) -import TcType (tcSplitSigmaTy) import TyCon -import TypeRep +import TyCoRep import TysPrim( funTyCon ) import Var hiding (varName) #define FSLIT(x) (mkFastString# (x#)) @@ -69,7 +68,7 @@ attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name] attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n)) - | let is = [ (instanceHead' i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ] + | 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 ] @@ -93,7 +92,7 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = , let opaque = isTypeHidden expInfo (fi_rhs i) ] cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d))) - | let is = [ (instanceHead' i, getName i) | i <- cls_instances ] + | let is = [ (instanceSig i, getName i) | i <- cls_instances ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys ] @@ -142,20 +141,6 @@ instLookup f name iface ifaceMap instIfaceMap = iface' <- Map.lookup (nameModule name) ifaceMaps Map.lookup name (f iface') --- | Like GHC's 'instanceHead' but drops "silent" arguments. -instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type]) -instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys) - where - dfun = is_dfun ispec - (tvs, cls, tys) = instanceHead ispec - (_, theta, _) = tcSplitSigmaTy (idType dfun) - --- | Drop "silent" arguments. See GHC Note [Silent superclass --- arguments]. -dropSilentArgs :: DFunId -> ThetaType -> ThetaType -dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta - - -- | Like GHC's getInfo but doesn't cut things out depending on the -- interative context, which we don't set sufficiently anyway. getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst])) @@ -185,18 +170,26 @@ instHead (_, _, cls, args) argCount :: Type -> Int argCount (AppTy t _) = argCount t + 1 argCount (TyConApp _ ts) = length ts -argCount (FunTy _ _ ) = 2 +argCount (ForAllTy (Anon _) _ ) = 2 argCount (ForAllTy _ t) = argCount t +argCount (CastTy t _) = argCount t argCount _ = 0 simplify :: Type -> SimpleType +simplify (ForAllTy (Anon t1) t2) = SimpleType funTyConName [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t -simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] -simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2]) +simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1 simplify (TyVarTy v) = SimpleType (tyVarName v) [] -simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts) +simplify (TyConApp tc ts) = SimpleType (tyConName tc) + (mapMaybe simplify_maybe ts) simplify (LitTy l) = SimpleTyLit l +simplify (CastTy ty _) = simplify ty +simplify (CoercionTy _) = error "simplify:Coercion" + +simplify_maybe :: Type -> Maybe SimpleType +simplify_maybe (CoercionTy {}) = Nothing +simplify_maybe ty = Just (simplify ty) -- Used for sorting instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType) @@ -246,9 +239,10 @@ isTypeHidden expInfo = typeHidden TyVarTy {} -> False AppTy t1 t2 -> typeHidden t1 || typeHidden t2 TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args - FunTy t1 t2 -> typeHidden t1 || typeHidden t2 - ForAllTy _ ty -> typeHidden ty + ForAllTy bndr ty -> typeHidden (binderType bndr) || typeHidden ty LitTy _ -> False + CastTy ty _ -> typeHidden ty + CoercionTy {} -> False nameHidden :: Name -> Bool nameHidden = isNameHidden expInfo diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index e158fb21..6466acfb 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -48,7 +48,9 @@ import Bag import RdrName import TcRnTypes import FastString (concatFS) +import BasicTypes ( StringLiteral(..) ) import qualified Outputable as O +import HsDecls ( gadtDeclDetails,getConDetails ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological @@ -165,21 +167,21 @@ mkAliasMap dflags mRenamedSource = alias <- ideclAs impDecl return $ (lookupModuleDyn dflags - (fmap Module.fsToPackageKey $ - ideclPkgQual impDecl) + (fmap Module.fsToUnitId $ + fmap sl_fs $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) impDecls -- similar to GHC.lookupModule lookupModuleDyn :: - DynFlags -> Maybe PackageKey -> ModuleName -> Module + DynFlags -> Maybe UnitId -> ModuleName -> Module lookupModuleDyn _ (Just pkgId) mdlName = Module.mkModule pkgId mdlName lookupModuleDyn dflags Nothing mdlName = case Packages.lookupModuleInAllPackages dflags mdlName of (m,_):_ -> m - [] -> Module.mkModule Module.mainPackageKey mdlName + [] -> Module.mkModule Module.mainUnitId mdlName ------------------------------------------------------------------------------- @@ -202,8 +204,8 @@ moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name parseWarning dflags gre w = force $ case w of - DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map unLoc msg) - WarningTxt _ msg -> format "Warning: " (concatFS $ map unLoc msg) + DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg) + WarningTxt _ msg -> format "Warning: " (concatFS $ map (sl_fs . unLoc) msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) . processDocString dflags gre $ HsDocString xs @@ -336,30 +338,30 @@ subordinates instMap decl = case decl of classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] + dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)] dataSubs dd = constrs ++ fields where cons = map unL $ (dd_cons dd) constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) - | c <- cons, cname <- con_names c ] - fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) - | RecCon flds <- map con_details cons + | c <- cons, cname <- getConNames c ] + fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) + | RecCon flds <- map getConDetails cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) - , n <- ns ] + , L _ n <- ns ] -- | Extract function argument docs from inside types. typeDocs :: HsDecl Name -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of - SigD (TypeSig _ ty _) -> docs (unLoc ty) - SigD (PatSynSig _ _ req prov ty) -> - let allTys = ty : concat [ unLoc req, unLoc prov ] - in F.foldMap (docs . unLoc) allTys - ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) + SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty)) + SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty)) + ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty)) TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) _ -> M.empty where - go n (HsForAllTy _ _ _ _ ty) = go n (unLoc ty) + 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 @@ -402,7 +404,7 @@ ungroup group_ = mkDecls (typesigs . hs_valds) SigD group_ ++ mkDecls (valbinds . hs_valds) ValD group_ where - typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs + typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs typesigs _ = error "expected ValBindsOut" valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds @@ -434,7 +436,7 @@ filterDecls = filter (isHandled . unL . fst) isHandled (ForD (ForeignImport {})) = True isHandled (TyClD {}) = True isHandled (InstD {}) = True - isHandled (SigD d) = isVanillaLSig (reL d) + isHandled (SigD d) = isUserLSig (reL d) isHandled (ValD _) = True -- we keep doc declarations to be able to get at named docs isHandled (DocD _) = True @@ -447,7 +449,7 @@ filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x | x@(L loc d, doc) <- decls ] where filterClass (TyClD c) = - TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c } + TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } filterClass _ = error "expected TyClD" @@ -506,7 +508,7 @@ mkExportItems 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 (IEThingWith (L _ t) _ _ _) = declWith t lookupExport (IEModuleContents (L _ m)) = moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $ @@ -561,7 +563,7 @@ mkExportItems L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef return [ mkExportDecl t (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] @@ -703,8 +705,8 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa "documentation for exported module: " ++ pretty dflags expMod] return [] where - m = mkModule packageKey expMod - packageKey = modulePackageKey thisMod + m = mkModule unitId expMod + unitId = moduleUnitId thisMod -- Note [1]: @@ -738,8 +740,8 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap expandSig = foldr f [] where f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] - f (L l (SigD (TypeSig names t nwcs))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t nwcs)) : acc) xs names - f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names + f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names + f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names f x xs = x : xs mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) @@ -759,7 +761,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . 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 @@ -783,64 +785,49 @@ extractDecl name mdl decl case unLoc decl of TyClD d@ClassDecl {} -> let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig, - isVanillaLSig sig ] -- TODO: document fixity + isTypeLSig sig ] -- TODO: document fixity in case matches of - [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d) - L pos sig = extractClassDecl n tyvar_names s0 + [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) + L pos sig = addClassContext n tyvar_names s0 in L pos (SigD sig) _ -> error "internal: extractDecl (ClassDecl)" TyClD d@DataDecl {} -> - let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d) - in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d)) + let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) + in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d)) InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n - , dfid_pats = HsWB { hswb_cts = tys } + , dfid_pats = HsIB { hsib_body = tys } , dfid_defn = defn }) -> SigD <$> extractRecSel name mdl n tys (dd_cons defn) InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d | L _ d <- insts - , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) + -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) + , RecCon rec <- map (getConDetails . unLoc) (dd_cons (dfid_defn d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns - , n == name + , selectorFieldOcc n == name ] in case matches of [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" - where - getTyVars = hsLTyVarLocNames . tyClDeclTyVars - - -toTypeNoLoc :: Located Name -> LHsType Name -toTypeNoLoc = noLoc . HsTyVar . unLoc - - -extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name -extractClassDecl c tvs0 (L pos (TypeSig lname ltype _)) = case ltype of - L _ (HsForAllTy expl _ tvs (L _ preds) ty) -> - L pos (TypeSig lname (noLoc (HsForAllTy expl Nothing tvs (lctxt preds) ty)) []) - _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit Nothing emptyHsQTvs (lctxt []) ltype)) []) - where - lctxt = noLoc . ctxt - ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds -extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl" - extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = - case con_details con of - RecCon (L _ fields) | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> - L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) []) + 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))))) _ -> extractRecSel nm mdl t tvs rest where - matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ] + matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)] + matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds + , L l n <- ns, selectorFieldOcc n == nm ] data_ty - | ResTyGADT _ ty <- con_res con = ty - | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs - + -- | 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 -- | Keep export items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name] diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 14826eaa..3c14498c 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -21,14 +21,15 @@ module Haddock.Interface.LexParseRn import Data.IntSet (toList) import Data.List import Documentation.Haddock.Doc (metaDocConcat) -import DynFlags (ExtensionFlag(..), languageExtensions) +import DynFlags (languageExtensions) +import qualified GHC.LanguageExtensions as LangExt import FastString import GHC import Haddock.Interface.ParseModuleHeader import Haddock.Parser import Haddock.Types import Name -import Outputable (showPpr) +import Outputable ( showPpr ) import RdrName import RnEnv (dataTcOccs) @@ -64,7 +65,7 @@ processModuleHeader dflags gre safety mayStr = do doc' = overDoc (rename dflags gre) doc return (hmi', Just doc') - let flags :: [ExtensionFlag] + let flags :: [LangExt.Extension] -- We remove the flags implied by the language setting and we display the language instead flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags) return (hmi { hmi_safety = Just $ showPpr dflags safety diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index dde8128d..a6223445 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -56,7 +56,8 @@ renameInterface dflags renamingEnv warnings iface = -- combine the missing names and filter out the built-ins, which would -- otherwise always be missing. missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much - (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4 ++ missingNames5) + (missingNames1 ++ missingNames2 ++ missingNames3 + ++ missingNames4 ++ missingNames5) -- filter out certain built in type constructors using their string -- representation. TODO: use the Name constants from the GHC API. @@ -95,13 +96,13 @@ newtype RnM a = instance Monad RnM where (>>=) = thenRn - return = returnRn + return = pure instance Functor RnM where fmap f x = do a <- x; return (f a) instance Applicative RnM where - pure = return + pure = returnRn (<*>) = ap returnRn :: a -> RnM a @@ -174,22 +175,51 @@ renameFnArgsDoc = mapM renameDoc renameLType :: LHsType Name -> RnM (LHsType DocName) renameLType = mapM renameType +renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName) +renameLSigType = renameImplicit renameLType + +renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName) +renameLSigWcType = renameImplicit (renameWc renameLType) + renameLKind :: LHsKind Name -> RnM (LHsKind DocName) renameLKind = renameLType renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) renameMaybeLKind = traverse renameLKind +renameFamilyResultSig :: LFamilyResultSig Name -> RnM (LFamilyResultSig DocName) +renameFamilyResultSig (L loc NoSig) + = return (L loc NoSig) +renameFamilyResultSig (L loc (KindSig ki)) + = do { ki' <- renameLKind ki + ; return (L loc (KindSig ki')) } +renameFamilyResultSig (L loc (TyVarSig bndr)) + = do { bndr' <- renameLTyVarBndr bndr + ; return (L loc (TyVarSig bndr')) } + +renameInjectivityAnn :: LInjectivityAnn Name -> RnM (LInjectivityAnn DocName) +renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) + = do { lhs' <- renameL lhs + ; rhs' <- mapM renameL rhs + ; return (L loc (InjectivityAnn lhs' rhs')) } + +renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn Name) + -> RnM (Maybe (LInjectivityAnn DocName)) +renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of - HsForAllTy expl extra tyvars lcontext ltype -> do - tyvars' <- renameLTyVarBndrs tyvars + HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do + tyvars' <- mapM renameLTyVarBndr tyvars + ltype' <- renameLType ltype + return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' }) + + HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsForAllTy expl extra tyvars' lcontext' ltype') + return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar n -> return . HsTyVar =<< rename n + HsTyVar (L l n) -> return . HsTyVar . L l =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype HsAppTy a b -> do @@ -209,11 +239,11 @@ renameType t = case t of HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - HsOpTy a (w, L loc op) b -> do + HsOpTy a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy a' (w, L loc op') b') + return (HsOpTy a' (L loc op') b') HsParTy ty -> return . HsParTy =<< renameLType ty @@ -229,29 +259,24 @@ renameType t = case t of HsTyLit x -> return (HsTyLit x) - HsWrapTy a b -> HsWrapTy a <$> renameType b HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a HsCoreTy a -> pure (HsCoreTy a) HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b - HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a HsSpliceTy _ _ -> error "renameType: HsSpliceTy" - HsWildcardTy -> pure HsWildcardTy - HsNamedWildcardTy a -> HsNamedWildcardTy <$> rename a + HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a + HsAppsTy _ -> error "renameType: HsAppsTy" -renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName) -renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c - -renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) -renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) +renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) +renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) } + ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs' }) } -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) -renameLTyVarBndr (L loc (UserTyVar n)) +renameLTyVarBndr (L loc (UserTyVar (L l n))) = do { n' <- rename n - ; return (L loc (UserTyVar n')) } + ; return (L loc (UserTyVar (L l n'))) } renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind @@ -262,6 +287,10 @@ renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') +renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName) +renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name +renameWildCardInfo (NamedWildCard (L l name)) = NamedWildCard . L l <$> rename name + renameInstHead :: InstHead Name -> RnM (InstHead DocName) renameInstHead InstHead {..} = do cname <- rename ihdClsName @@ -270,7 +299,7 @@ renameInstHead InstHead {..} = do itype <- case ihdInstType of ClassInst { .. } -> ClassInst <$> mapM renameType clsiCtx - <*> renameLTyVarBndrs clsiTyVars + <*> renameLHsQTyVars clsiTyVars <*> mapM renameSig clsiSigs <*> mapM renamePseudoFamilyDecl clsiAssocTys TypeInst ts -> TypeInst <$> traverse renameType ts @@ -314,13 +343,13 @@ renameTyClD d = case d of SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do lname' <- renameL lname - tyvars' <- renameLTyVarBndrs tyvars + tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames }) DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do lname' <- renameL lname - tyvars' <- renameLTyVarBndrs tyvars + tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = placeHolderNames }) @@ -328,7 +357,7 @@ renameTyClD d = case d of , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do lcontext' <- renameLContext lcontext lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars + ltyvars' <- renameLHsQTyVars ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM (renameLThing renameFamilyDecl) ats @@ -348,13 +377,16 @@ renameTyClD d = case d of renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname - , fdTyVars = ltyvars, fdKindSig = tckind }) = do - info' <- renameFamilyInfo info - lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars - tckind' <- renameMaybeLKind tckind + , fdTyVars = ltyvars, fdResultSig = result + , fdInjectivityAnn = injectivity }) = do + info' <- renameFamilyInfo info + lname' <- renameL lname + ltyvars' <- renameLHsQTyVars ltyvars + result' <- renameFamilyResultSig result + injectivity' <- renameMaybeInjectivityAnn injectivity return (FamilyDecl { fdInfo = info', fdLName = lname' - , fdTyVars = ltyvars', fdKindSig = tckind' }) + , fdTyVars = ltyvars', fdResultSig = result' + , fdInjectivityAnn = injectivity' }) renamePseudoFamilyDecl :: PseudoFamilyDecl Name @@ -363,14 +395,14 @@ renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl <$> renameFamilyInfo pfdInfo <*> renameL pfdLName <*> mapM renameLType pfdTyVars - <*> renameMaybeLKind pfdKindSig + <*> renameFamilyResultSig pfdKindSig renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily renameFamilyInfo (ClosedTypeFamily eqns) - = do { eqns' <- mapM renameLTyFamInstEqn eqns + = do { eqns' <- mapM (mapM renameLTyFamInstEqn) eqns ; return $ ClosedTypeFamily eqns' } renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName) @@ -384,17 +416,16 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing }) renameCon :: ConDecl Name -> RnM (ConDecl DocName) -renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars - , con_cxt = lcontext, con_details = details - , con_res = restype, con_doc = mbldoc }) = do - lnames' <- mapM renameL lnames - ltyvars' <- renameLTyVarBndrs ltyvars - lcontext' <- renameLContext lcontext +renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars + , con_cxt = lcontext, con_details = details + , con_doc = mbldoc }) = do + lname' <- renameL lname + ltyvars' <- traverse renameLHsQTyVars ltyvars + lcontext' <- traverse renameLContext lcontext details' <- renameDetails details - restype' <- renameResType restype mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_names = lnames', con_qvars = ltyvars', con_cxt = lcontext' - , con_details = details', con_res = restype', con_doc = mbldoc' }) + return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' + , con_details = details', con_doc = mbldoc' }) where renameDetails (RecCon (L l fields)) = do @@ -406,35 +437,47 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars b' <- renameLType b return (InfixCon a' b') - renameResType (ResTyH98) = return ResTyH98 - renameResType (ResTyGADT l t) = return . ResTyGADT l =<< renameLType t - +renameCon decl@(ConDeclGADT { con_names = lnames + , con_type = lty + , con_doc = mbldoc }) = do + lnames' <- mapM renameL lnames + lty' <- renameLSigType lty + mbldoc' <- mapM renameLDocHsSyn mbldoc + return (decl { con_names = lnames' + , con_type = lty', con_doc = mbldoc' }) renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) renameConDeclFieldField (L l (ConDeclField names t doc)) = do - names' <- mapM renameL names + names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc return $ L l (ConDeclField names' t' doc') +renameLFieldOcc :: LFieldOcc Name -> RnM (LFieldOcc DocName) +renameLFieldOcc (L l (FieldOcc lbl sel)) = do + sel' <- rename sel + return $ L l (FieldOcc lbl sel') renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of - TypeSig lnames ltype _ -> do + TypeSig lnames ltype -> do lnames' <- mapM renameL lnames - ltype' <- renameLType ltype - return (TypeSig lnames' ltype' PlaceHolder) - PatSynSig lname (flag, qtvs) lreq lprov lty -> do + ltype' <- renameLSigWcType ltype + return (TypeSig lnames' ltype') + ClassOpSig is_default lnames sig_ty -> do + lnames' <- mapM renameL lnames + ltype' <- renameLSigType sig_ty + return (ClassOpSig is_default lnames' ltype') + PatSynSig lname sig_ty -> do lname' <- renameL lname - qtvs' <- renameLTyVarBndrs qtvs - lreq' <- renameLContext lreq - lprov' <- renameLContext lprov - lty' <- renameLType lty - return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty' + sig_ty' <- renameLSigType sig_ty + return $ PatSynSig lname' sig_ty' FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames return $ FixSig (FixitySig lnames' fixity) - MinimalSig src s -> MinimalSig src <$> traverse renameL s + MinimalSig src (L l s) -> do + s' <- traverse renameL s + return $ MinimalSig src (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" @@ -442,11 +485,11 @@ renameSig sig = case sig of renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) renameForD (ForeignImport lname ltype co x) = do lname' <- renameL lname - ltype' <- renameLType ltype + ltype' <- renameLSigType ltype return (ForeignImport lname' ltype' co x) renameForD (ForeignExport lname ltype co x) = do lname' <- renameL lname - ltype' <- renameLType ltype + ltype' <- renameLSigType ltype return (ForeignExport lname' ltype' co x) @@ -465,7 +508,7 @@ renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty =ltype, cid_tyfam_insts = lATs , cid_datafam_insts = lADTs }) = do - ltype' <- renameLType ltype + ltype' <- renameLSigType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs return (ClsInstDecl { cid_overlap_mode = omode @@ -481,33 +524,48 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) , tfid_fvs = placeHolderNames }) } renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName) -renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, tfe_rhs = rhs })) +renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs })) = do { tc' <- renameL tc - ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) + ; pats' <- renameImplicit (mapM renameLType) pats ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' - , tfe_pats = HsWB pats' PlaceHolder PlaceHolder PlaceHolder + , tfe_pats = pats' , tfe_rhs = rhs' })) } renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs })) - = do { tc' <- renameL tc - ; tvs' <- renameLTyVarBndrs tvs + = do { tc' <- renameL tc + ; tvs' <- renameLHsQTyVars tvs ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' , tfe_pats = tvs' , tfe_rhs = rhs' })) } renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) -renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn }) +renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_defn = defn }) = do { tc' <- renameL tc - ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) + ; pats' <- renameImplicit (mapM renameLType) pats ; defn' <- renameDataDefn defn ; return (DataFamInstDecl { dfid_tycon = tc' - , dfid_pats - = HsWB pats' PlaceHolder PlaceHolder PlaceHolder + , dfid_pats = pats' , dfid_defn = defn', dfid_fvs = placeHolderNames }) } +renameImplicit :: (in_thing -> RnM out_thing) + -> HsImplicitBndrs Name in_thing + -> RnM (HsImplicitBndrs DocName out_thing) +renameImplicit rn_thing (HsIB { hsib_body = thing }) + = do { thing' <- rn_thing thing + ; return (HsIB { hsib_body = thing' + , hsib_vars = PlaceHolder }) } + +renameWc :: (in_thing -> RnM out_thing) + -> HsWildCardBndrs Name in_thing + -> RnM (HsWildCardBndrs DocName out_thing) +renameWc rn_thing (HsWC { hswc_body = thing }) + = do { thing' <- rn_thing thing + ; return (HsWC { hswc_body = thing' + , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) } + renameDocInstance :: DocInstance Name -> RnM (DocInstance DocName) renameDocInstance (inst, idoc, L l n) = do inst' <- renameInstHead inst diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index d6466570..ab719fe8 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 name') | name == name' = details + step (HsTyVar (L _ name')) | name == name' = details step typ = typ @@ -54,20 +54,20 @@ specialize' = flip $ foldr (uncurry specialize) -- -- 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 :: (Eq name, Typeable name, DataId name) +specializeTyVarBndrs :: (Eq name, DataId name) => Data a - => LHsTyVarBndrs name -> [HsType name] + => LHsQTyVars name -> [HsType name] -> a -> a specializeTyVarBndrs bndrs typs = specialize' $ zip bndrs' typs where - bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs - bname (UserTyVar name) = name + bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs + bname (UserTyVar (L _ name)) = name bname (KindedTyVar (L _ name) _) = name -specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name) - => LHsTyVarBndrs name -> [HsType name] +specializePseudoFamilyDecl :: (Eq name, DataId name) + => LHsQTyVars name -> [HsType name] -> PseudoFamilyDecl name -> PseudoFamilyDecl name specializePseudoFamilyDecl bndrs typs decl = @@ -76,21 +76,24 @@ specializePseudoFamilyDecl bndrs typs decl = specializeTyVars = specializeTyVarBndrs bndrs typs -specializeSig :: (Eq name, Typeable name, DataId name, SetName name) - => LHsTyVarBndrs name -> [HsType name] +specializeSig :: forall name . (Eq name, DataId name, SetName name) + => LHsQTyVars name -> [HsType name] -> Sig name -> Sig name -specializeSig bndrs typs (TypeSig lnames (L loc typ) prn) = - TypeSig lnames (L loc typ') prn +specializeSig bndrs typs (TypeSig lnames typ) = + TypeSig lnames (typ { hsib_body = (hsib_body typ) { hswc_body = noLoc typ'}}) where - typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs typ + true_type :: HsType name + true_type = unLoc (hswc_body (hsib_body typ)) + typ' :: HsType name + typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type fv = foldr Set.union Set.empty . map freeVariables $ typs specializeSig _ _ sig = sig -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type. -specializeInstHead :: (Eq name, Typeable name, DataId name, SetName name) +specializeInstHead :: (Eq name, DataId name, SetName name) => InstHead name -> InstHead name specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = ihd { ihdInstType = instType' } @@ -120,7 +123,7 @@ sugar = sugarLists :: NamedThing name => HsType name -> HsType name -sugarLists (HsAppTy (L _ (HsTyVar name)) ltyp) +sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp) | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp where name' = getName name @@ -134,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 name) + aux apps (HsTyVar (L _ name)) | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps where name' = getName name @@ -146,8 +149,8 @@ sugarTuples typ = sugarOperators :: NamedThing name => HsType name -> HsType name -sugarOperators (HsAppTy (L _ (HsAppTy (L loc (HsTyVar name)) la)) lb) - | isSymOcc $ getOccName name' = mkHsOpTy la (L loc name) 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 name' = getName name @@ -219,13 +222,13 @@ freeVariables = everythingWithState Set.empty Set.union query where query term ctx = case cast term :: Maybe (HsType name) of - Just (HsForAllTy _ _ bndrs _ _) -> + Just (HsForAllTy bndrs _) -> (Set.empty, Set.union ctx (bndrsNames bndrs)) - Just (HsTyVar name) + Just (HsTyVar (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getNameRep name, ctx) _ -> (Set.empty, ctx) - bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs + bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) -- | Make given type visually unambiguous. @@ -256,26 +259,26 @@ data RenameEnv name = RenameEnv renameType :: SetName name => HsType name -> Rename name (HsType name) -renameType (HsForAllTy ex mspan lbndrs lctx lt) = rebind lbndrs $ \lbndrs' -> +renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' -> HsForAllTy - <$> pure ex - <*> pure mspan - <*> pure lbndrs' - <*> located renameContext lctx + <$> pure bndrs' <*> renameLType lt -renameType (HsTyVar name) = HsTyVar <$> renameName name +renameType (HsQualTy lctxt lt) = + HsQualTy + <$> located renameContext lctxt + <*> renameLType lt +renameType (HsTyVar name) = HsTyVar <$> 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 (HsOpTy la lop lb) = - HsOpTy <$> renameLType la <*> renameLTyOp lop <*> renameLType 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 t@(HsQuasiQuoteTy _) = pure t renameType t@(HsSpliceTy _ _) = pure t renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt @@ -286,9 +289,8 @@ renameType (HsExplicitListTy ph ltys) = renameType (HsExplicitTupleTy phs ltys) = HsExplicitTupleTy phs <$> renameLTypes ltys renameType t@(HsTyLit _) = pure t -renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t -renameType HsWildcardTy = pure HsWildcardTy -renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name +renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) +renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming" renameLType :: SetName name => LHsType name -> Rename name (LHsType name) @@ -302,21 +304,20 @@ renameLTypes = mapM renameLType renameContext :: SetName name => HsContext name -> Rename name (HsContext name) renameContext = renameLTypes - +{- renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name) renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname +-} renameName :: SetName name => name -> Rename name name renameName name = do RenameEnv { rneCtx = ctx } <- ask - pure $ case Map.lookup (getName name) ctx of - Just name' -> name' - Nothing -> name + pure $ fromMaybe name (Map.lookup (getName name) ctx) rebind :: SetName name - => LHsTyVarBndrs name -> (LHsTyVarBndrs name -> Rename name a) + => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename name a) -> Rename name a rebind lbndrs action = do (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask @@ -324,16 +325,14 @@ rebind lbndrs action = do rebindLTyVarBndrs :: SetName name - => LHsTyVarBndrs name -> Rebind name (LHsTyVarBndrs name) -rebindLTyVarBndrs lbndrs = do - tys' <- mapM (located rebindTyVarBndr) $ hsq_tvs lbndrs - pure $ lbndrs { hsq_tvs = tys' } + => [LHsTyVarBndr name] -> Rebind name [LHsTyVarBndr name] +rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs rebindTyVarBndr :: SetName name => HsTyVarBndr name -> Rebind name (HsTyVarBndr name) -rebindTyVarBndr (UserTyVar name) = - UserTyVar <$> rebindName name +rebindTyVarBndr (UserTyVar (L l name)) = + UserTyVar . L l <$> rebindName name rebindTyVarBndr (KindedTyVar name kinds) = KindedTyVar <$> located rebindName name <*> pure kinds @@ -403,5 +402,5 @@ located f (L loc e) = L loc <$> f e tyVarName :: HsTyVarBndr name -> name -tyVarName (UserTyVar name) = name +tyVarName (UserTyVar name) = unLoc name tyVarName (KindedTyVar (L _ name) _) = name diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index d5762ce8..73185092 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -14,7 +14,7 @@ -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- module Haddock.InterfaceFile ( - InterfaceFile(..), ifModule, ifPackageKey, + InterfaceFile(..), ifUnitId, ifModule, readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where @@ -57,8 +57,11 @@ ifModule if_ = [] -> error "empty InterfaceFile" iface:_ -> instMod iface -ifPackageKey :: InterfaceFile -> PackageKey -ifPackageKey = modulePackageKey . ifModule +ifUnitId :: InterfaceFile -> UnitId +ifUnitId if_ = + case ifInstalledIfaces if_ of + [] -> error "empty InterfaceFile" + iface:_ -> moduleUnitId $ instMod iface binaryInterfaceMagic :: Word32 @@ -78,7 +81,7 @@ binaryInterfaceMagic = 0xD0Cface -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if (__GLASGOW_HASKELL__ >= 709) && (__GLASGOW_HASKELL__ < 711) +#if (__GLASGOW_HASKELL__ >= 711) && (__GLASGOW_HASKELL__ < 713) binaryInterfaceVersion = 27 binaryInterfaceVersionCompatibility :: [Word16] @@ -312,7 +315,7 @@ getSymbolTable bh namecache = do return (namecache', arr) -type OnDiskName = (PackageKey, ModuleName, OccName) +type OnDiskName = (UnitId, ModuleName, OccName) fromOnDiskName @@ -342,7 +345,7 @@ fromOnDiskName _ nc (pid, mod_name, occ) = serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () serialiseName bh name _ = do let modu = nameModule name - put_ bh (modulePackageKey modu, moduleName modu, nameOccName name) + put_ bh (moduleUnitId modu, moduleName modu, nameOccName name) ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs index 2f731214..e6cf8201 100644 --- a/haddock-api/src/Haddock/ModuleTree.hs +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -15,7 +15,7 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where import Haddock.Types ( MDoc ) import GHC ( Name ) -import Module ( Module, moduleNameString, moduleName, modulePackageKey, packageKeyString ) +import Module ( Module, moduleNameString, moduleName, moduleUnitId, unitIdString ) import DynFlags ( DynFlags ) import Packages ( lookupPackage ) import PackageConfig ( sourcePackageIdString ) @@ -28,10 +28,10 @@ mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree mkModuleTree dflags showPkgs mods = foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where - modPkg mod_ | showPkgs = Just (packageKeyString (modulePackageKey mod_)) + modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_)) | otherwise = Nothing modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString - (lookupPackage dflags (modulePackageKey mod_)) + (lookupPackage dflags (moduleUnitId mod_)) | otherwise = Nothing fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index c6631671..34e99a8a 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -33,11 +33,13 @@ import Documentation.Haddock.Types import BasicTypes (Fixity(..)) import GHC hiding (NoLink) -import DynFlags (ExtensionFlag, Language) +import DynFlags (Language) +import qualified GHC.LanguageExtensions as LangExt import Coercion import NameSet import OccName import Outputable +import Control.Applicative (Applicative(..)) import Control.Monad (ap) import Haddock.Backends.Hyperlinker.Types @@ -299,11 +301,18 @@ type instance PostTc DocName Kind = PlaceHolder type instance PostTc DocName Type = PlaceHolder type instance PostTc DocName Coercion = PlaceHolder - instance NamedThing DocName where getName (Documented name _) = name getName (Undocumented name) = name +-- | Useful for debugging +instance Outputable DocName where + ppr = ppr . getName + +instance OutputableBndr DocName where + pprBndr _ = ppr . getName + pprPrefixOcc = pprPrefixOcc . getName + pprInfixOcc = pprInfixOcc . getName class NamedThing name => SetName name where @@ -330,7 +339,7 @@ instance SetName DocName where data InstType name = ClassInst { clsiCtx :: [HsType name] - , clsiTyVars :: LHsTyVarBndrs name + , clsiTyVars :: LHsQTyVars name , clsiSigs :: [Sig name] , clsiAssocTys :: [PseudoFamilyDecl name] } @@ -357,7 +366,7 @@ data PseudoFamilyDecl name = PseudoFamilyDecl { pfdInfo :: FamilyInfo name , pfdLName :: Located name , pfdTyVars :: [LHsType name] - , pfdKindSig :: Maybe (LHsKind name) + , pfdKindSig :: LFamilyResultSig name } @@ -365,14 +374,14 @@ mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl { pfdInfo = fdInfo , pfdLName = fdLName - , pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_tvs fdTyVars ] - , pfdKindSig = fdKindSig + , pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_explicit fdTyVars ] + , pfdKindSig = fdResultSig } where mkType (KindedTyVar (L loc name) lkind) = HsKindSig tvar lkind where - tvar = L loc (HsTyVar name) + tvar = L loc (HsTyVar (L loc name)) mkType (UserTyVar name) = HsTyVar name @@ -498,7 +507,7 @@ data HaddockModInfo name = HaddockModInfo , hmi_portability :: Maybe String , hmi_safety :: Maybe String , hmi_language :: Maybe Language - , hmi_extensions :: [ExtensionFlag] + , hmi_extensions :: [LangExt.Extension] } @@ -590,11 +599,11 @@ instance Functor ErrMsgM where fmap f (Writer (a, msgs)) = Writer (f a, msgs) instance Applicative ErrMsgM where - pure = return - (<*>) = ap + pure a = Writer (a, []) + (<*>) = ap instance Monad ErrMsgM where - return a = Writer (a, []) + return = pure m >>= k = Writer $ let (a, w) = runWriter m (b, w') = runWriter (k a) @@ -643,10 +652,27 @@ instance Functor ErrMsgGhc where fmap f (WriterGhc x) = WriterGhc (fmap (first f) x) instance Applicative ErrMsgGhc where - pure = return + pure a = WriterGhc (return (a, [])) (<*>) = ap instance Monad ErrMsgGhc where - return a = WriterGhc (return (a, [])) + return = pure m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> fmap (second (msgs1 ++)) (runWriterGhc (k a)) + + +----------------------------------------------------------------------------- +-- * Pass sensitive types +----------------------------------------------------------------------------- + +type instance PostRn DocName NameSet = PlaceHolder +type instance PostRn DocName Fixity = PlaceHolder +type instance PostRn DocName Bool = PlaceHolder +type instance PostRn DocName Name = DocName +type instance PostRn DocName (Located Name) = Located DocName +type instance PostRn DocName [Name] = PlaceHolder +type instance PostRn DocName DocName = DocName + +type instance PostTc DocName Kind = PlaceHolder +type instance PostTc DocName Type = PlaceHolder +type instance PostTc DocName Coercion = PlaceHolder diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 4fed3a1e..3510d908 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -16,6 +16,7 @@ module Haddock.Utils ( -- * Misc utilities restrictTo, emptyHsQTvs, toDescription, toInstalledDescription, + mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes, -- * Filename utilities moduleHtmlFile, moduleHtmlFile', @@ -63,6 +64,7 @@ import Haddock.GhcUtils import GHC import Name +import HsTypes (selectorFieldOcc) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) @@ -123,6 +125,34 @@ toInstalledDescription = fmap mkMeta . hmi_description . instInfo mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } +mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name +-- Dubious, because the implicit binders are empty even +-- though the type might have free varaiables +mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty) + +addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name +-- Add the class context to a class-op signature +addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) + = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype)))) + -- The mkEmptySigWcType is suspicious + where + go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty })) + = L loc (HsForAllTy { hst_bndrs = tvs, hst_body = go ty }) + go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) + = L loc (HsQualTy { hst_ctxt = add_ctxt ctxt, hst_body = ty }) + go (L loc ty) + = L loc (HsQualTy { hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) + + extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) + add_ctxt (L loc preds) = L loc (extra_pred : preds) + +addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine + +lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] +lHsQTyVarsToTypes tvs + = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv))) + | tv <- hsQTvExplicit tvs ] + -------------------------------------------------------------------------------- -- * Making abstract declarations -------------------------------------------------------------------------------- @@ -150,19 +180,36 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where - keep d | any (\n -> n `elem` names) (map unLoc $ con_names d) = - case con_details d of + keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = + case getConDetails h98d of PrefixCon _ -> Just d RecCon fields | all field_avail (unL fields) -> Just d - | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL (unL fields))) }) + | otherwise -> Just (h98d { con_details = PrefixCon (field_types (map unL (unL 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 -- it's the best we can do. InfixCon _ _ -> Just d where - field_avail (L _ (ConDeclField ns _ _)) = all (\n -> unLoc n `elem` names) ns + h98d = h98ConDecl d + h98ConDecl c@ConDeclH98{} = c + h98ConDecl c@ConDeclGADT{} = c' + where + (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c) + c' :: ConDecl Name + c' = ConDeclH98 + { con_name = head (con_names c) + , con_qvars = Just $ HsQTvs { hsq_implicit = mempty + , hsq_explicit = tvs } + , con_cxt = Just cxt + , con_details = details + , con_doc = con_doc c + } + + field_avail :: LConDeclField Name -> Bool + field_avail (L _ (ConDeclField fs _ _)) + = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs field_types flds = [ t | ConDeclField _ t _ <- flds ] keep _ = Nothing @@ -174,11 +221,12 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] -emptyHsQTvs :: LHsTyVarBndrs Name +emptyHsQTvs :: LHsQTyVars Name -- This function is here, rather than in HsTypes, because it *renamed*, but -- does not necessarily have all the rigt kind variables. It is used -- in Haddock just for printing, so it doesn't matter -emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] } +emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs" + , hsq_explicit = [] } -------------------------------------------------------------------------------- diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index c2ea73b0..f60501f5 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -21,7 +21,7 @@ library default-language: Haskell2010 build-depends: - base >= 4.5 && < 4.9 + base >= 4.5 && < 4.10 , bytestring , transformers , deepseq diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs index 6719e09a..9c7994e9 100644 --- a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs +++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs @@ -126,7 +126,7 @@ instance Monad (Parser i) where where msg = "Failed reading: " ++ err {-# INLINE fail #-} - return v = Parser $ \t pos more _lose succ -> succ t pos more v + return = pure {-# INLINE return #-} m >>= k = Parser $ \t !pos more lose succ -> @@ -158,7 +158,7 @@ apP d e = do {-# INLINE apP #-} instance Applicative (Parser i) where - pure = return + pure v = Parser $ \t pos more _lose succ -> succ t pos more v {-# INLINE pure #-} (<*>) = apP {-# INLINE (<*>) #-} @@ -166,7 +166,7 @@ instance Applicative (Parser i) where -- These definitions are equal to the defaults, but this -- way the optimizer doesn't have to work so hard to figure -- that out. - (*>) = (>>) + m *> k = m >>= \_ -> k {-# INLINE (*>) #-} x <* y = x >>= \a -> y >> return a {-# INLINE (<*) #-} diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal new file mode 100644 index 00000000..0394da8f --- /dev/null +++ b/haddock-test/haddock-test.cabal @@ -0,0 +1,28 @@ +name: haddock-test +version: 0.0.1 +synopsis: Test utilities for Haddock +license: BSD3 +author: Simon Marlow, David Waern +maintainer: Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> +homepage: http://www.haskell.org/haddock/ +bug-reports: https://github.com/haskell/haddock/issues +copyright: (c) Simon Marlow, David Waern +category: Documentation +build-type: Simple +cabal-version: >= 1.10 +stability: experimental + +library + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: src + build-depends: base, directory, process, filepath, Cabal, xml, xhtml, syb + + exposed-modules: + Test.Haddock + Test.Haddock.Config + Test.Haddock.Xhtml + + other-modules: + Test.Haddock.Process + Test.Haddock.Utils diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs new file mode 100644 index 00000000..e8a0ac8e --- /dev/null +++ b/haddock-test/src/Test/Haddock.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE RecordWildCards #-} + + +module Test.Haddock + ( module Test.Haddock.Config + , runAndCheck, runHaddock, checkFiles + ) where + + +import Control.Monad + +import Data.Maybe + +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.Process + +import Test.Haddock.Config +import Test.Haddock.Process +import Test.Haddock.Utils + + +data CheckResult + = Fail + | Pass + | NoRef + | Error String + | Accepted + deriving Eq + + +runAndCheck :: Config c -> IO () +runAndCheck cfg = do + runHaddock cfg + checkFiles cfg + + +checkFiles :: Config c -> IO () +checkFiles cfg@(Config { .. }) = do + putStrLn "Testing output files..." + + files <- ignore <$> getDirectoryTree (cfgOutDir cfg) + failed <- liftM catMaybes . forM files $ \file -> do + putStr $ "Checking \"" ++ file ++ "\"... " + + status <- maybeAcceptFile cfg file =<< checkFile cfg file + case status of + Fail -> putStrLn "FAIL" >> (return $ Just file) + Pass -> putStrLn "PASS" >> (return Nothing) + NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing) + Error msg -> putStrLn ("ERROR (" ++ msg ++ ")") >> return Nothing + Accepted -> putStrLn "ACCEPTED" >> return Nothing + + if null failed + then do + putStrLn "All tests passed!" + exitSuccess + else do + maybeDiff cfg failed + exitFailure + where + ignore = filter (not . dcfgCheckIgnore cfgDirConfig) + + +maybeDiff :: Config c -> [FilePath] -> IO () +maybeDiff (Config { cfgDiffTool = Nothing }) _ = pure () +maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do + putStrLn "Diffing failed cases..." + forM_ files $ diffFile cfg diff + + +runHaddock :: Config c -> IO () +runHaddock cfg@(Config { .. }) = do + createEmptyDirectory $ cfgOutDir cfg + + putStrLn "Generating documentation..." + forM_ cfgPackages $ \tpkg -> do + haddockStdOut <- openFile cfgHaddockStdOut WriteMode + handle <- runProcess' cfgHaddockPath $ processConfig + { pcArgs = concat + [ cfgHaddockArgs + , pure $ "--odir=" ++ outDir cfgDirConfig tpkg + , tpkgFiles tpkg + ] + , pcEnv = Just $ cfgEnv + , pcStdOut = Just $ haddockStdOut + } + waitForSuccess "Failed to run Haddock on specified test files" handle + + +checkFile :: Config c -> FilePath -> IO CheckResult +checkFile cfg file = do + hasRef <- doesFileExist $ refFile dcfg file + if hasRef + then do + mout <- ccfgRead ccfg file <$> readFile (outFile dcfg file) + mref <- ccfgRead ccfg file <$> readFile (refFile dcfg file) + return $ case (mout, mref) of + (Just out, Just ref) + | ccfgEqual ccfg out ref -> Pass + | otherwise -> Fail + _ -> Error "Failed to parse input files" + else return NoRef + where + ccfg = cfgCheckConfig cfg + dcfg = cfgDirConfig cfg + + +diffFile :: Config c -> FilePath -> FilePath -> IO () +diffFile cfg diff file = do + Just out <- ccfgRead ccfg file <$> readFile (outFile dcfg file) + Just ref <- ccfgRead ccfg file <$> readFile (refFile dcfg file) + writeFile outFile' $ ccfgDump ccfg out + writeFile refFile' $ ccfgDump ccfg ref + + putStrLn $ "Diff for file \"" ++ file ++ "\":" + hFlush stdout + handle <- runProcess' diff $ processConfig + { pcArgs = [outFile', refFile'] + , pcStdOut = Just $ stdout + } + waitForProcess handle >> return () + where + dcfg = cfgDirConfig cfg + ccfg = cfgCheckConfig cfg + outFile' = outFile dcfg file <.> "dump" + refFile' = outFile dcfg file <.> "ref" <.> "dump" + + +maybeAcceptFile :: Config c -> FilePath -> CheckResult -> IO CheckResult +maybeAcceptFile cfg@(Config { cfgDirConfig = dcfg }) file result + | cfgAccept cfg && result `elem` [NoRef, Fail] = do + copyFile' (outFile dcfg file) (refFile dcfg file) + pure Accepted +maybeAcceptFile _ _ result = pure result + + +outDir :: DirConfig -> TestPackage -> FilePath +outDir dcfg tpkg = dcfgOutDir dcfg </> tpkgName tpkg + + +outFile :: DirConfig -> FilePath -> FilePath +outFile dcfg file = dcfgOutDir dcfg </> file + + +refFile :: DirConfig -> FilePath -> FilePath +refFile dcfg file = dcfgRefDir dcfg </> file diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs new file mode 100644 index 00000000..cd878178 --- /dev/null +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} + +module Test.Haddock.Config + ( TestPackage(..), CheckConfig(..), DirConfig(..), Config(..) + , defaultDirConfig + , cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir + , parseArgs, checkOpt, loadConfig + ) where + + +import Control.Applicative +import Control.Monad + +import qualified Data.List as List +import Data.Maybe + +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.Simple.Compiler hiding (Flag) +import Distribution.Simple.GHC +import Distribution.Simple.PackageIndex +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Verbosity + +import System.Console.GetOpt +import System.Directory +import System.Exit +import System.Environment +import System.FilePath +import System.IO + +import Test.Haddock.Process +import Test.Haddock.Utils + + +data TestPackage = TestPackage + { tpkgName :: String + , tpkgFiles :: [FilePath] + } + + +data CheckConfig c = CheckConfig + { ccfgRead :: String -> String -> Maybe c + , ccfgDump :: c -> String + , ccfgEqual :: c -> c -> Bool + } + + +data DirConfig = DirConfig + { dcfgSrcDir :: FilePath + , dcfgRefDir :: FilePath + , dcfgOutDir :: FilePath + , dcfgResDir :: FilePath + , dcfgCheckIgnore :: FilePath -> Bool + } + + +defaultDirConfig :: FilePath -> DirConfig +defaultDirConfig baseDir = DirConfig + { dcfgSrcDir = baseDir </> "src" + , dcfgRefDir = baseDir </> "ref" + , dcfgOutDir = baseDir </> "out" + , dcfgResDir = rootDir </> "resources" + , dcfgCheckIgnore = const False + } + where + rootDir = baseDir </> ".." + + +data Config c = Config + { cfgHaddockPath :: FilePath + , cfgPackages :: [TestPackage] + , cfgHaddockArgs :: [String] + , cfgHaddockStdOut :: FilePath + , cfgDiffTool :: Maybe FilePath + , cfgEnv :: Environment + , cfgAccept :: Bool + , cfgCheckConfig :: CheckConfig c + , cfgDirConfig :: DirConfig + } + + +cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir :: Config c -> FilePath +cfgSrcDir = dcfgSrcDir . cfgDirConfig +cfgRefDir = dcfgRefDir . cfgDirConfig +cfgOutDir = dcfgOutDir . cfgDirConfig +cfgResDir = dcfgResDir . cfgDirConfig + + + +data Flag + = FlagHaddockPath FilePath + | FlagHaddockOptions String + | FlagHaddockStdOut FilePath + | FlagDiffTool FilePath + | FlagNoDiff + | FlagAccept + | FlagHelp + deriving Eq + + +flagsHaddockPath :: [Flag] -> Maybe FilePath +flagsHaddockPath flags = mlast [ path | FlagHaddockPath path <- flags ] + + +flagsHaddockOptions :: [Flag] -> [String] +flagsHaddockOptions flags = concat + [ words opts | FlagHaddockOptions opts <- flags ] + + +flagsHaddockStdOut :: [Flag] -> Maybe FilePath +flagsHaddockStdOut flags = mlast [ path | FlagHaddockStdOut path <- flags ] + + +flagsDiffTool :: [Flag] -> Maybe FilePath +flagsDiffTool flags = mlast [ path | FlagDiffTool path <- flags ] + + +options :: [OptDescr Flag] +options = + [ Option [] ["haddock-path"] (ReqArg FlagHaddockPath "FILE") + "path to Haddock executable to exectue tests with" + , Option [] ["haddock-options"] (ReqArg FlagHaddockOptions "OPTS") + "additional options to run Haddock with" + , Option [] ["haddock-stdout"] (ReqArg FlagHaddockStdOut "FILE") + "where to redirect Haddock output" + , Option [] ["diff-tool"] (ReqArg FlagDiffTool "PATH") + "diff tool to use when printing failed cases" + , Option ['a'] ["accept"] (NoArg FlagAccept) + "accept generated output" + , Option [] ["no-diff"] (NoArg FlagNoDiff) + "do not print diff for failed cases" + , Option ['h'] ["help"] (NoArg FlagHelp) + "display this help end exit" + ] + + +parseArgs :: CheckConfig c -> DirConfig -> [String] -> IO (Config c) +parseArgs ccfg dcfg args = uncurry (loadConfig ccfg dcfg) =<< checkOpt args + + +checkOpt :: [String] -> IO ([Flag], [String]) +checkOpt args = do + let (flags, files, errors) = getOpt Permute options args + + unless (null errors) $ do + hPutStr stderr $ concat errors + exitFailure + + when (FlagHelp `elem` flags) $ do + hPutStrLn stderr $ usageInfo "" options + exitSuccess + + return (flags, files) + + +loadConfig :: CheckConfig c -> DirConfig -> [Flag] -> [String] -> IO (Config c) +loadConfig ccfg dcfg flags files = do + cfgEnv <- (:) ("haddock_datadir", dcfgResDir dcfg) <$> getEnvironment + + systemHaddockPath <- List.lookup "HADDOCK_PATH" <$> getEnvironment + cfgHaddockPath <- case flagsHaddockPath flags <|> systemHaddockPath of + Just path -> pure path + Nothing -> do + hPutStrLn stderr $ "Haddock executable not specified" + exitFailure + + ghcPath <- init <$> rawSystemStdout normal cfgHaddockPath + ["--print-ghc-path"] + + printVersions cfgEnv cfgHaddockPath + + cfgPackages <- processFileArgs dcfg files + + cfgHaddockArgs <- liftM concat . sequence $ + [ pure ["--no-warnings"] + , pure ["--odir=" ++ dcfgOutDir dcfg] + , pure ["--optghc=-w"] + , pure $ flagsHaddockOptions flags + , baseDependencies ghcPath + ] + + let cfgHaddockStdOut = fromMaybe "/dev/null" (flagsHaddockStdOut flags) + + cfgDiffTool <- if FlagNoDiff `elem` flags + then pure Nothing + else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool + + let cfgAccept = FlagAccept `elem` flags + + let cfgCheckConfig = ccfg + let cfgDirConfig = dcfg + + return $ Config { .. } + + +printVersions :: Environment -> FilePath -> IO () +printVersions env haddockPath = do + handleHaddock <- runProcess' haddockPath $ processConfig + { pcEnv = Just env + , pcArgs = ["--version"] + } + waitForSuccess "Failed to run `haddock --version`" handleHaddock + + handleGhc <- runProcess' haddockPath $ processConfig + { pcEnv = Just env + , pcArgs = ["--ghc-version"] + } + waitForSuccess "Failed to run `haddock --ghc-version`" handleGhc + + +baseDependencies :: FilePath -> IO [String] +baseDependencies ghcPath = do + -- The 'getInstalledPackages' crashes if used when "GHC_PACKAGE_PATH" is + -- set to some value. I am not sure why is that happening and what are the + -- consequences of unsetting it - but looks like it works (for now). + unsetEnv "GHC_PACKAGE_PATH" + + (comp, _, cfg) <- configure normal (Just ghcPath) Nothing + defaultProgramConfiguration +#if MIN_VERSION_Cabal(1,23,0) + pkgIndex <- getInstalledPackages normal comp [GlobalPackageDB] cfg +#else + pkgIndex <- getInstalledPackages normal [GlobalPackageDB] cfg +#endif + mapM (getDependency pkgIndex) ["base", "process", "ghc-prim"] + where + getDependency pkgIndex name = case ifaces pkgIndex name of + [] -> do + hPutStrLn stderr $ "Couldn't find base test dependency: " ++ name + exitFailure + (ifArg:_) -> pure ifArg + ifaces pkgIndex name = do + pkg <- join $ snd <$> lookupPackageName pkgIndex (PackageName name) + iface <$> haddockInterfaces pkg <*> haddockHTMLs pkg + iface file html = "--read-interface=" ++ html ++ "," ++ file + + +defaultDiffTool :: IO (Maybe FilePath) +defaultDiffTool = + liftM listToMaybe . filterM isAvailable $ ["colordiff", "diff"] + where + isAvailable = liftM isJust . findProgramLocation silent + + +processFileArgs :: DirConfig -> [String] -> IO [TestPackage] +processFileArgs dcfg [] = + processFileArgs' dcfg . filter isValidEntry =<< getDirectoryContents srcDir + where + isValidEntry entry + | hasExtension entry = isSourceFile entry + | otherwise = isRealDir entry + srcDir = dcfgSrcDir dcfg +processFileArgs dcfg args = processFileArgs' dcfg args + + +processFileArgs' :: DirConfig -> [String] -> IO [TestPackage] +processFileArgs' dcfg args = do + (dirs, mdls) <- partitionM doesDirectoryExist' . map takeBaseName $ args + rootPkg <- pure $ TestPackage + { tpkgName = "" + , tpkgFiles = map (srcDir </>) mdls + } + otherPkgs <- forM dirs $ \dir -> do + let srcDir' = srcDir </> dir + files <- filterM (isModule dir) =<< getDirectoryContents srcDir' + pure $ TestPackage + { tpkgName = dir + , tpkgFiles = map (srcDir' </>) files + } + pure . filter (not . null . tpkgFiles) $ rootPkg:otherPkgs + where + doesDirectoryExist' path = doesDirectoryExist (srcDir </> path) + isModule dir file = (isSourceFile file &&) <$> + doesFileExist (srcDir </> dir </> file) + srcDir = dcfgSrcDir dcfg + + +isSourceFile :: FilePath -> Bool +isSourceFile file = takeExtension file `elem` [".hs", ".lhs"] + + +isRealDir :: FilePath -> Bool +isRealDir dir = not $ dir `elem` [".", ".."] diff --git a/haddock-test/src/Test/Haddock/Process.hs b/haddock-test/src/Test/Haddock/Process.hs new file mode 100644 index 00000000..ae720f6f --- /dev/null +++ b/haddock-test/src/Test/Haddock/Process.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE RecordWildCards #-} + + +module Test.Haddock.Process where + + +import Control.Monad + +import System.Exit +import System.IO +import System.Process + + +type Environment = [(String, String)] + + +data ProcessConfig = ProcessConfig + { pcArgs :: [String] + , pcWorkDir :: Maybe FilePath + , pcEnv :: Maybe Environment + , pcStdIn :: Maybe Handle + , pcStdOut :: Maybe Handle + , pcStdErr :: Maybe Handle + } + + +processConfig :: ProcessConfig +processConfig = ProcessConfig + { pcArgs = [] + , pcWorkDir = Nothing + , pcEnv = Nothing + , pcStdIn = Nothing + , pcStdOut = Nothing + , pcStdErr = Nothing + } + + +runProcess' :: FilePath -> ProcessConfig -> IO ProcessHandle +runProcess' path (ProcessConfig { .. }) = runProcess + path pcArgs pcWorkDir pcEnv pcStdIn pcStdOut pcStdErr + + +waitForSuccess :: String -> ProcessHandle -> IO () +waitForSuccess msg handle = do + result <- waitForProcess handle + unless (result == ExitSuccess) $ do + hPutStrLn stderr $ msg + exitFailure diff --git a/haddock-test/src/Test/Haddock/Utils.hs b/haddock-test/src/Test/Haddock/Utils.hs new file mode 100644 index 00000000..a947fea1 --- /dev/null +++ b/haddock-test/src/Test/Haddock/Utils.hs @@ -0,0 +1,50 @@ +module Test.Haddock.Utils where + + +import Control.Monad + +import Data.Maybe + +import System.Directory +import System.FilePath + + +mlast :: [a] -> Maybe a +mlast = listToMaybe . reverse + + +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM _ [] = pure ([], []) +partitionM p (x:xs) = do + (ss, fs) <- partitionM p xs + b <- p x + pure $ if b then (x:ss, fs) else (ss, x:fs) + + +whenM :: Monad m => m Bool -> m () -> m () +whenM mb action = mb >>= \b -> when b action + + +getDirectoryTree :: FilePath -> IO [FilePath] +getDirectoryTree path = do + (dirs, files) <- partitionM isDirectory =<< contents + subfiles <- fmap concat . forM dirs $ \dir -> + map (dir </>) <$> getDirectoryTree (path </> dir) + pure $ files ++ subfiles + where + contents = filter realEntry <$> getDirectoryContents path + isDirectory entry = doesDirectoryExist $ path </> entry + realEntry entry = not $ entry == "." || entry == ".." + + +createEmptyDirectory :: FilePath -> IO () +createEmptyDirectory path = do + whenM (doesDirectoryExist path) $ removeDirectoryRecursive path + createDirectory path + + +-- | Just like 'copyFile' but output directory path is not required to exist. +copyFile' :: FilePath -> FilePath -> IO () +copyFile' old new = do + createDirectoryIfMissing True $ takeDirectory new + copyFile old new diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs new file mode 100644 index 00000000..69361f7c --- /dev/null +++ b/haddock-test/src/Test/Haddock/Xhtml.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} + + +module Test.Haddock.Xhtml + ( Xml(..) + , parseXml, dumpXml + , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter + ) where + + +import Data.Generics.Aliases +import Data.Generics.Schemes + +import Text.XML.Light +import Text.XHtml (Html, HtmlAttr, (!)) +import qualified Text.XHtml as Xhtml + + +newtype Xml = Xml + { xmlElement :: Element + } deriving Eq + + +-- TODO: Find a way to avoid warning about orphan instances. +deriving instance Eq Element +deriving instance Eq Content +deriving instance Eq CData + + +parseXml :: String -> Maybe Xml +parseXml = fmap Xml . parseXMLDoc + + +dumpXml :: Xml -> String +dumpXml = Xhtml.renderHtmlFragment. xmlElementToXhtml . xmlElement + + +stripLinks :: Xml -> Xml +stripLinks = stripLinksWhen (const True) + + +stripLinksWhen :: (String -> Bool) -> Xml -> Xml +stripLinksWhen p = + processAnchors unlink + where + unlink attr@(Attr { attrKey = key, attrVal = val }) + | qName key == "href" && p val = attr { attrVal = "#" } + | otherwise = attr + + +stripAnchorsWhen :: (String -> Bool) -> Xml -> Xml +stripAnchorsWhen p = + processAnchors unname + where + unname attr@(Attr { attrKey = key, attrVal = val }) + | qName key == "name" && p val = attr { attrVal = "" } + | otherwise = attr + + +processAnchors :: (Attr -> Attr) -> Xml -> Xml +processAnchors f = Xml . everywhere (mkT f) . xmlElement + + +stripFooter :: Xml -> Xml +stripFooter = + Xml . everywhere (mkT defoot) . xmlElement + where + defoot el + | isFooter el = el { elContent = [] } + | otherwise = el + isFooter el = any isFooterAttr $ elAttribs el + isFooterAttr (Attr { .. }) = and + [ qName attrKey == "id" + , attrVal == "footer" + ] + + +xmlElementToXhtml :: Element -> Html +xmlElementToXhtml (Element { .. }) = + Xhtml.tag (qName elName) contents ! attrs + where + contents = mconcat $ map xmlContentToXhtml elContent + attrs = map xmlAttrToXhtml elAttribs + + +xmlContentToXhtml :: Content -> Html +xmlContentToXhtml (Elem el) = xmlElementToXhtml el +xmlContentToXhtml (Text text) = Xhtml.toHtml $ cdData text +xmlContentToXhtml (CRef _) = Xhtml.noHtml + + +xmlAttrToXhtml :: Attr -> HtmlAttr +xmlAttrToXhtml (Attr { .. }) = Xhtml.strAttr (qName attrKey) attrVal diff --git a/haddock.cabal b/haddock.cabal index 71b78347..294e1526 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -47,7 +47,7 @@ executable haddock ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded build-depends: - base >= 4.3 && < 4.9 + base >= 4.3 && < 4.10 if flag(in-ghc-tree) hs-source-dirs: haddock-api/src, haddock-library/vendor/attoparsec-0.12.1.1, haddock-library/src cpp-options: -DIN_GHC_TREE @@ -59,7 +59,8 @@ executable haddock array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, - ghc >= 7.9 && < 7.12, + ghc-boot, + ghc >= 7.11 && < 7.13, bytestring, transformers @@ -125,24 +126,31 @@ executable haddock test-suite html-test type: exitcode-stdio-1.0 default-language: Haskell2010 - main-is: run.lhs + main-is: Main.hs hs-source-dirs: html-test - build-depends: base, directory, process, filepath, Cabal + build-depends: base, filepath, haddock-test test-suite hypsrc-test type: exitcode-stdio-1.0 default-language: Haskell2010 - main-is: run.hs + main-is: Main.hs hs-source-dirs: hypsrc-test - build-depends: base, directory, process, filepath, Cabal + build-depends: base, filepath, haddock-test ghc-options: -Wall -fwarn-tabs test-suite latex-test type: exitcode-stdio-1.0 default-language: Haskell2010 - main-is: run.lhs + main-is: Main.hs hs-source-dirs: latex-test - build-depends: base, directory, process, filepath, Cabal + build-depends: base, filepath, haddock-test + +test-suite hoogle-test + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: hoogle-test + build-depends: base, filepath, haddock-test source-repository head type: git diff --git a/hoogle-test/Main.hs b/hoogle-test/Main.hs new file mode 100644 index 00000000..c8cda640 --- /dev/null +++ b/hoogle-test/Main.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP #-} + + +import System.Environment +import System.FilePath + +import Test.Haddock + + +checkConfig :: CheckConfig String +checkConfig = CheckConfig + { ccfgRead = \_ input -> Just input + , ccfgDump = id + , ccfgEqual = (==) + } + + +dirConfig :: DirConfig +dirConfig = defaultDirConfig $ takeDirectory __FILE__ + + +main :: IO () +main = do + cfg <- parseArgs checkConfig dirConfig =<< getArgs + runAndCheck $ cfg + { cfgHaddockArgs = cfgHaddockArgs cfg ++ + [ "--package-name=test" + , "--package-version=0.0.0" + , "--hoogle" + ] + } diff --git a/hoogle-test/ref/assoc-types/test.txt b/hoogle-test/ref/assoc-types/test.txt new file mode 100644 index 00000000..ba1a145a --- /dev/null +++ b/hoogle-test/ref/assoc-types/test.txt @@ -0,0 +1,14 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module AssocTypes +class Foo a where { + type family Bar a b; + type family Baz a; + type Baz a = [(a, a)]; +} +bar :: Foo a => Bar a a +instance AssocTypes.Foo [a] diff --git a/hoogle-test/ref/classes/test.txt b/hoogle-test/ref/classes/test.txt new file mode 100644 index 00000000..69f224eb --- /dev/null +++ b/hoogle-test/ref/classes/test.txt @@ -0,0 +1,17 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Classes +class Foo f +bar :: Foo f => f a -> f b -> f (a, b) +baz :: Foo f => f () +class Quux q +(+++) :: Quux q => q -> q -> q +(///) :: Quux q => q -> q -> q +(***) :: Quux q => q -> q -> q +logBase :: Quux q => q -> q -> q +foo :: Quux q => q -> q -> q +quux :: Quux q => q -> q -> q diff --git a/hoogle-test/ref/fixity/test.txt b/hoogle-test/ref/fixity/test.txt new file mode 100644 index 00000000..6f609539 --- /dev/null +++ b/hoogle-test/ref/fixity/test.txt @@ -0,0 +1,13 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Fixity +(+++) :: a -> a -> a +infix 6 +++ +(***) :: a -> a -> a +infixl 7 *** +(///) :: a -> a -> a +infixr 8 /// diff --git a/hoogle-test/ref/modules/test.txt b/hoogle-test/ref/modules/test.txt new file mode 100644 index 00000000..6705b790 --- /dev/null +++ b/hoogle-test/ref/modules/test.txt @@ -0,0 +1,13 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Foo +foo :: Int -> Int +foo' :: Int -> Int -> Int + +module Bar +bar :: Int -> Int +bar' :: Int -> Int -> Int diff --git a/hoogle-test/run b/hoogle-test/run new file mode 100755 index 00000000..3e72be80 --- /dev/null +++ b/hoogle-test/run @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +export HADDOCK_PATH=$(which haddock) +LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" +MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" +runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ diff --git a/hoogle-test/src/assoc-types/AssocTypes.hs b/hoogle-test/src/assoc-types/AssocTypes.hs new file mode 100644 index 00000000..a9bdc6d8 --- /dev/null +++ b/hoogle-test/src/assoc-types/AssocTypes.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TypeFamilies #-} + + +module AssocTypes where + + +class Foo a where + + type Bar a b + type Baz a + + type Baz a = [(a, a)] + + bar :: Bar a a + bar = undefined + + +instance Foo [a] where + + type Bar [a] Int = [(a, Bool)] + type Bar [a] Bool = [(Int, a)] + + type Baz [a] = (a, a, a) diff --git a/hoogle-test/src/classes/Classes.hs b/hoogle-test/src/classes/Classes.hs new file mode 100644 index 00000000..23f68499 --- /dev/null +++ b/hoogle-test/src/classes/Classes.hs @@ -0,0 +1,16 @@ +module Classes where + + +class Foo f where + + bar :: f a -> f b -> f (a, b) + baz :: f () + + baz = undefined + + +class Quux q where + + (+++), (///) :: q -> q -> q + (***), logBase :: q -> q -> q + foo, quux :: q -> q -> q diff --git a/hoogle-test/src/fixity/Fixity.hs b/hoogle-test/src/fixity/Fixity.hs new file mode 100644 index 00000000..3af38117 --- /dev/null +++ b/hoogle-test/src/fixity/Fixity.hs @@ -0,0 +1,12 @@ +module Fixity where + + +(+++), (***), (///) :: a -> a -> a +(+++) = undefined +(***) = undefined +(///) = undefined + + +infix 6 +++ +infixl 7 *** +infixr 8 /// diff --git a/hoogle-test/src/modules/Bar.hs b/hoogle-test/src/modules/Bar.hs new file mode 100644 index 00000000..156a835f --- /dev/null +++ b/hoogle-test/src/modules/Bar.hs @@ -0,0 +1,12 @@ +module Bar where + + +import Foo + + +bar :: Int -> Int +bar x = foo' x x + + +bar' :: Int -> Int -> Int +bar' x y = foo' (bar (foo x)) (bar (foo y)) diff --git a/hoogle-test/src/modules/Foo.hs b/hoogle-test/src/modules/Foo.hs new file mode 100644 index 00000000..6581fe4c --- /dev/null +++ b/hoogle-test/src/modules/Foo.hs @@ -0,0 +1,9 @@ +module Foo where + + +foo :: Int -> Int +foo = (* 2) + + +foo' :: Int -> Int -> Int +foo' x y = foo x + foo y diff --git a/html-test/Main.hs b/html-test/Main.hs new file mode 100755 index 00000000..3880fc3c --- /dev/null +++ b/html-test/Main.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP #-} + + +import Data.Char + +import System.Environment +import System.FilePath + +import Test.Haddock +import Test.Haddock.Xhtml + + +checkConfig :: CheckConfig Xml +checkConfig = CheckConfig + { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXml input + , ccfgDump = dumpXml + , ccfgEqual = (==) + } + + +dirConfig :: DirConfig +dirConfig = (defaultDirConfig $ takeDirectory __FILE__) + { dcfgCheckIgnore = checkIgnore + } + + +main :: IO () +main = do + cfg <- parseArgs checkConfig dirConfig =<< getArgs + runAndCheck $ cfg + { cfgHaddockArgs = cfgHaddockArgs cfg ++ ["--pretty-html", "--html"] + } + + +stripIfRequired :: String -> Xml -> Xml +stripIfRequired mdl = + stripLinks' . stripFooter + where + stripLinks' + | mdl `elem` preserveLinksModules = id + | otherwise = stripLinks + + +-- | List of modules in which we don't 'stripLinks' +preserveLinksModules :: [String] +preserveLinksModules = ["Bug253"] + + +checkIgnore :: FilePath -> Bool +checkIgnore file@(c:_) | takeExtension file == ".html" && isUpper c = False +checkIgnore _ = True diff --git a/html-test/README.markdown b/html-test/README.markdown deleted file mode 100644 index 717bac5c..00000000 --- a/html-test/README.markdown +++ /dev/null @@ -1,27 +0,0 @@ -This is a testsuite for Haddock that uses the concept of "golden files". That -is, it compares output files against a set of reference files. - -To add a new test: - - 1. Create a module in the `html-test/src` directory. - - 2. Run `cabal test`. You should now have `html-test/out/<modulename>.html`. - The test passes since there is no reference file to compare with. - - 3. To make a reference file from the output file, run - - html-test/accept.lhs <modulename> - -Tips and tricks: - -To "accept" all output files (copy them to reference files), run - - runhaskell accept.lhs - -You can run all tests despite failing tests, like so - - cabal test --test-option=all - -You can pass extra options to haddock like so - - cabal test --test-options='all --title="All Tests"' diff --git a/html-test/accept.lhs b/html-test/accept.lhs deleted file mode 100755 index f6dfc4cd..00000000 --- a/html-test/accept.lhs +++ /dev/null @@ -1,49 +0,0 @@ -#!/usr/bin/env runhaskell -\begin{code} -{-# LANGUAGE CPP #-} -import System.Cmd -import System.Environment -import System.FilePath -import System.Directory -import Data.List -import Control.Applicative - -baseDir = takeDirectory __FILE__ - -main :: IO () -main = do - contents <- filter (not . ignore) <$> getDirectoryContents (baseDir </> "out") - args <- getArgs - if not $ null args then - mapM_ copy [ baseDir </> "out" </> file | file <- contents, ".html" `isSuffixOf` file, takeBaseName file `elem` args ] - else - mapM_ copy [ baseDir </> "out" </> file | file <- contents] - where - ignore = - foldr (liftA2 (||)) (const False) [ - (== ".") - , (== "..") - , (isPrefixOf "index") - , (isPrefixOf "doc-index") - ] - -copy :: FilePath -> IO () -copy file = do - let new = baseDir </> "ref" </> takeFileName file - if ".html" `isSuffixOf` file then do - putStrLn (file ++ " -> " ++ new) - stripLinks <$> readFile file >>= writeFile new - else do - -- copy css, images, etc. - copyFile file new - -stripLinks :: String -> String -stripLinks str = - let prefix = "<a href=\"" in - case stripPrefix prefix str of - Just str' -> prefix ++ stripLinks (dropWhile (/= '"') str') - Nothing -> - case str of - [] -> [] - x : xs -> x : stripLinks xs -\end{code} diff --git a/html-test/run b/html-test/run new file mode 100755 index 00000000..3e72be80 --- /dev/null +++ b/html-test/run @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +export HADDOCK_PATH=$(which haddock) +LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" +MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" +runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ diff --git a/html-test/run.lhs b/html-test/run.lhs deleted file mode 100755 index 1f19b723..00000000 --- a/html-test/run.lhs +++ /dev/null @@ -1,191 +0,0 @@ -#!/usr/bin/env runhaskell -\begin{code} -{-# LANGUAGE CPP #-} -import Prelude hiding (mod) -import Control.Monad -import Control.Applicative -import Data.List -import Data.Maybe -import Distribution.InstalledPackageInfo -import Distribution.Package (PackageName (..)) -import Distribution.Simple.Compiler -import Distribution.Simple.GHC -import Distribution.Simple.PackageIndex -import Distribution.Simple.Program -import Distribution.Simple.Utils -import Distribution.Verbosity -import System.IO -import System.Directory -import System.Environment -import System.Exit -import System.FilePath -import System.Process (ProcessHandle, runProcess, waitForProcess, system) - -packageRoot, dataDir, haddockPath, baseDir, testDir, outDir :: FilePath -baseDir = takeDirectory __FILE__ -testDir = baseDir </> "src" -refDir = baseDir </> "ref" -outDir = baseDir </> "out" -packageRoot = baseDir </> ".." -dataDir = packageRoot </> "resources" -haddockPath = packageRoot </> "dist" </> "build" </> "haddock" </> "haddock" - - -main :: IO () -main = do - test - putStrLn "All tests passed!" - - -test :: IO () -test = do - x <- doesFileExist haddockPath - unless x $ System.Exit.die "you need to run 'cabal build' successfully first" - - contents <- getDirectoryContents testDir - args <- getArgs - let (opts, spec) = span ("-" `isPrefixOf`) args - let mods = - case spec of - y:_ | y /= "all" -> [y ++ ".hs"] - _ -> filter ((==) ".hs" . takeExtension) contents - - let mods' = map (testDir </>) mods - - -- add haddock_datadir to environment for subprocesses - env <- Just . (:) ("haddock_datadir", Main.dataDir) <$> getEnvironment - - putStrLn "" - putStrLn "Haddock version: " - h1 <- runProcess haddockPath ["--version"] Nothing - env Nothing Nothing Nothing - wait h1 "*** Running `haddock --version' failed!" - putStrLn "" - putStrLn "GHC version: " - h2 <- runProcess haddockPath ["--ghc-version"] Nothing - env Nothing Nothing Nothing - wait h2 "*** Running `haddock --ghc-version' failed!" - putStrLn "" - - -- TODO: maybe do something more clever here using haddock.cabal - ghcPath <- fmap init $ rawSystemStdout normal haddockPath ["--print-ghc-path"] - (_, _, conf) <- configure normal (Just ghcPath) Nothing defaultProgramConfiguration - pkgIndex <- getInstalledPackages normal [GlobalPackageDB] conf - let mkDep pkgName = - fromMaybe (error "Couldn't find test dependencies") $ do - let pkgs = lookupPackageName pkgIndex (PackageName pkgName) - (_, pkgs') <- listToMaybe pkgs - pkg <- listToMaybe pkgs' - ifacePath <- listToMaybe (haddockInterfaces pkg) - htmlPath <- listToMaybe (haddockHTMLs pkg) - return ("-i " ++ htmlPath ++ "," ++ ifacePath) - - let base = mkDep "base" - process = mkDep "process" - ghcprim = mkDep "ghc-prim" - - putStrLn "Running tests..." - handle <- runProcess haddockPath - (["-w", "-o", outDir, "-h", "--pretty-html" - , "--optghc=-w", base, process, ghcprim] ++ opts ++ mods') - Nothing env Nothing - Nothing Nothing - - wait handle "*** Haddock run failed! Exiting." - check mods (if not (null args) && args !! 0 == "all" then False else True) - where - wait :: ProcessHandle -> String -> IO () - wait h msg = do - r <- waitForProcess h - unless (r == ExitSuccess) $ do - hPutStrLn stderr msg - exitFailure - -check :: [FilePath] -> Bool -> IO () -check modules strict = do - forM_ modules $ \mod -> do - let outfile = outDir </> dropExtension mod ++ ".html" - let reffile = refDir </> dropExtension mod ++ ".html" - b <- doesFileExist reffile - if b - then do - out <- readFile outfile - ref <- readFile reffile - if not $ haddockEq (outfile, out) (reffile, ref) - then do - putStrLn $ "Output for " ++ mod ++ " has changed! Exiting with diff:" - let ref' = maybeStripLinks outfile ref - out' = maybeStripLinks reffile out - let reffile' = outDir </> takeFileName reffile ++ ".nolinks" - outfile' = outDir </> takeFileName outfile ++ ".ref.nolinks" - writeFile reffile' ref' - writeFile outfile' out' - r <- programOnPath "colordiff" - code <- if r - then system $ "colordiff " ++ reffile' ++ " " ++ outfile' - else system $ "diff " ++ reffile' ++ " " ++ outfile' - if strict then exitFailure else return () - unless (code == ExitSuccess) $ do - hPutStrLn stderr "*** Running diff failed!" - exitFailure - else do - putStrLn $ "Pass: " ++ mod - else do - putStrLn $ "Pass: " ++ mod ++ " (no .ref file)" - --- | List of modules in which we don't 'stripLinks' -preserveLinksModules :: [String] -preserveLinksModules = map (++ ".html") ["Bug253"] - --- | A rather nasty way to drop the Haddock version string from the --- end of the generated HTML files so that we don't have to change --- every single test every time we change versions. We rely on the the --- last paragraph of the document to be the version. We end up with --- malformed HTML but we don't care as we never look at it ourselves. -dropVersion :: String -> String -dropVersion = reverse . dropTillP . reverse - where - dropTillP [] = [] - dropTillP ('p':'<':xs) = xs - dropTillP (_:xs) = dropTillP xs - -haddockEq :: (FilePath, String) -> (FilePath, String) -> Bool -haddockEq (fn1, file1) (fn2, file2) = - maybeStripLinks fn1 (dropVersion file1) - == maybeStripLinks fn2 (dropVersion file2) - -maybeStripLinks :: String -- ^ Module we're considering for stripping - -> String -> String -maybeStripLinks m = if any (`isSuffixOf` m) preserveLinksModules - then id - else stripLinks - -stripLinks :: String -> String -stripLinks str = - let prefix = "<a href=\"" in - case stripPrefix prefix str of - Just str' -> case dropWhile (/= '>') (dropWhile (/= '"') str') of - [] -> [] - x:xs -> stripLinks (stripHrefEnd xs) - Nothing -> - case str of - [] -> [] - x : xs -> x : stripLinks xs - -stripHrefEnd :: String -> String -stripHrefEnd s = - let pref = "</a" in - case stripPrefix pref s of - Just str' -> case dropWhile (/= '>') str' of - [] -> [] - x:xs -> xs - Nothing -> - case s of - [] -> [] - x : xs -> x : stripHrefEnd xs - -programOnPath :: FilePath -> IO Bool -programOnPath p = do - result <- findProgramLocation silent p - return (isJust result) -\end{code} diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs new file mode 100644 index 00000000..0490be47 --- /dev/null +++ b/hypsrc-test/Main.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} + + +import Data.Char +import Data.List + +import System.Environment +import System.FilePath + +import Test.Haddock +import Test.Haddock.Xhtml + + +checkConfig :: CheckConfig Xml +checkConfig = CheckConfig + { ccfgRead = \_ input -> strip <$> parseXml input + , ccfgDump = dumpXml + , ccfgEqual = (==) + } + where + strip = stripAnchors' . stripLinks' . stripFooter + stripLinks' = stripLinksWhen $ \href -> "#local-" `isPrefixOf` href + stripAnchors' = stripAnchorsWhen $ \name -> "local-" `isPrefixOf` name + + +dirConfig :: DirConfig +dirConfig = (defaultDirConfig $ takeDirectory __FILE__) + { dcfgCheckIgnore = checkIgnore + } + + +main :: IO () +main = do + cfg <- parseArgs checkConfig dirConfig =<< getArgs + runAndCheck $ cfg + { cfgHaddockArgs = cfgHaddockArgs cfg ++ + [ "--pretty-html" + , "--hyperlinked-source" + ] + } + + +checkIgnore :: FilePath -> Bool +checkIgnore file + | and . map ($ file) $ [isHtmlFile, isSourceFile, isModuleFile] = False + where + isHtmlFile = (== ".html") . takeExtension + isSourceFile = (== "src") . takeDirectory + isModuleFile = isUpper . head . takeBaseName +checkIgnore _ = True diff --git a/hypsrc-test/Utils.hs b/hypsrc-test/Utils.hs deleted file mode 100644 index e15fabee..00000000 --- a/hypsrc-test/Utils.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE CPP #-} - - -module Utils - ( baseDir, rootDir - , srcDir, refDir, outDir, refDir', outDir' - , haddockPath - , stripLocalAnchors, stripLocalLinks, stripLocalReferences - ) where - - -import Data.List - -import System.FilePath - - -baseDir, rootDir :: FilePath -baseDir = takeDirectory __FILE__ -rootDir = baseDir </> ".." - -srcDir, refDir, outDir, refDir', outDir' :: FilePath -srcDir = baseDir </> "src" -refDir = baseDir </> "ref" -outDir = baseDir </> "out" -refDir' = refDir </> "src" -outDir' = outDir </> "src" - -haddockPath :: FilePath -haddockPath = rootDir </> "dist" </> "build" </> "haddock" </> "haddock" - - -replaceBetween :: Eq a => [a] -> a -> [a] -> [a] -> [a] -replaceBetween _ _ _ [] = [] -replaceBetween pref end val html@(x:xs') = case stripPrefix pref html of - Just strip -> pref ++ val ++ (replaceBetween' . dropWhile (/= end)) strip - Nothing -> x:(replaceBetween' xs') - where - replaceBetween' = replaceBetween pref end val - -stripLocalAnchors :: String -> String -stripLocalAnchors = replaceBetween "<a name=\"local-" '\"' "0" - -stripLocalLinks :: String -> String -stripLocalLinks = replaceBetween "<a href=\"#local-" '\"' "0" - -stripLocalReferences :: String -> String -stripLocalReferences = stripLocalLinks . stripLocalAnchors diff --git a/hypsrc-test/accept.hs b/hypsrc-test/accept.hs deleted file mode 100755 index 4606b2df..00000000 --- a/hypsrc-test/accept.hs +++ /dev/null @@ -1,27 +0,0 @@ -#!/usr/bin/env runhaskell -{-# LANGUAGE CPP #-} - - -import System.Directory -import System.FilePath -import System.Environment - -import Utils - - -main :: IO () -main = do - args <- getArgs - files <- filter isHtmlFile <$> getDirectoryContents outDir' - let files' = if args == ["--all"] || args == ["-a"] - then files - else filter ((`elem` args) . takeBaseName) files - mapM_ copy files' - where - isHtmlFile = (== ".html") . takeExtension - - -copy :: FilePath -> IO () -copy file = do - content <- stripLocalReferences <$> readFile (outDir' </> file) - writeFile (refDir' </> file) content diff --git a/hypsrc-test/run b/hypsrc-test/run new file mode 100755 index 00000000..3e72be80 --- /dev/null +++ b/hypsrc-test/run @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +export HADDOCK_PATH=$(which haddock) +LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" +MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" +runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs deleted file mode 100755 index 853c4f09..00000000 --- a/hypsrc-test/run.hs +++ /dev/null @@ -1,122 +0,0 @@ -#!/usr/bin/env runhaskell -{-# LANGUAGE CPP #-} - - -import Control.Monad - -import Data.List -import Data.Maybe - -import System.Directory -import System.Environment -import System.Exit -import System.FilePath -import System.Process - -import Distribution.Verbosity -import Distribution.Simple.Utils hiding (die) - -import Utils - - -main :: IO () -main = do - haddockAvailable <- doesFileExist haddockPath - unless haddockAvailable $ die "Haddock exectuable not available" - - (args, mods) <- partition ("-" `isPrefixOf`) <$> getArgs - let args' = filter (\arg -> not $ arg == "--all" || arg == "-a") args - mods' <- map (srcDir </>) <$> case args of - [] -> getAllSrcModules - _ -> return $ map (++ ".hs") mods - - putHaddockVersion - putGhcVersion - - putStrLn "Running tests..." - runHaddock $ - [ "--odir=" ++ outDir - , "--no-warnings" - , "--hyperlinked-source" - , "--pretty-html" - ] ++ args' ++ mods' - - forM_ mods' $ check True - - -check :: Bool -> FilePath -> IO () -check strict mdl = do - hasReference <- doesFileExist refFile - if hasReference - then do - ref <- readFile refFile - out <- readFile outFile - compareOutput strict mdl ref out - else do - putStrLn $ "Pass: " ++ mdl ++ " (no reference file)" - where - refFile = refDir' </> takeBaseName mdl ++ ".html" - outFile = outDir' </> takeBaseName mdl ++ ".html" - - -compareOutput :: Bool -> FilePath -> String -> String -> IO () -compareOutput strict mdl ref out = do - if ref' == out' - then putStrLn $ "Pass: " ++ mdl - else do - putStrLn $ "Fail: " ++ mdl - diff mdl ref' out' - when strict $ die "Aborting further tests." - where - ref' = stripLocalReferences ref - out' = stripLocalReferences out - - -diff :: FilePath -> String -> String -> IO () -diff mdl ref out = do - colorDiffPath <- findProgramLocation silent "colordiff" - let cmd = fromMaybe "diff" colorDiffPath - - writeFile refFile ref - writeFile outFile out - - result <- system $ cmd ++ " " ++ refFile ++ " " ++ outFile - unless (result == ExitSuccess) $ die "Failed to run `diff` command." - where - refFile = outDir </> takeBaseName mdl ++ ".ref.nolinks" - outFile = outDir </> takeBaseName mdl ++ ".nolinks" - - - -getAllSrcModules :: IO [FilePath] -getAllSrcModules = - filter isHaskellFile <$> getDirectoryContents srcDir - where - isHaskellFile = (== ".hs") . takeExtension - - -putHaddockVersion :: IO () -putHaddockVersion = do - putStrLn "Haddock version:" - runHaddock ["--version"] - putStrLn "" - - -putGhcVersion :: IO () -putGhcVersion = do - putStrLn "GHC version:" - runHaddock ["--ghc-version"] - putStrLn "" - - -runHaddock :: [String] -> IO () -runHaddock args = do - menv <- Just <$> getEnvironment - handle <- runProcess haddockPath args Nothing menv Nothing Nothing Nothing - waitForSuccess handle $ "Failed to invoke haddock with " ++ show args - - -waitForSuccess :: ProcessHandle -> String -> IO () -waitForSuccess handle msg = do - result <- waitForProcess handle - unless (result == ExitSuccess) $ die msg diff --git a/latex-test/Main.hs b/latex-test/Main.hs new file mode 100755 index 00000000..2ee01a26 --- /dev/null +++ b/latex-test/Main.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} + + +import System.Environment +import System.FilePath + +import Test.Haddock + + +checkConfig :: CheckConfig String +checkConfig = CheckConfig + { ccfgRead = \_ input -> Just input + , ccfgDump = id + , ccfgEqual = (==) + } + + +dirConfig :: DirConfig +dirConfig = defaultDirConfig $ takeDirectory __FILE__ + + +main :: IO () +main = do + cfg <- parseArgs checkConfig dirConfig =<< getArgs + runAndCheck $ cfg + { cfgHaddockArgs = cfgHaddockArgs cfg ++ ["--latex"] + } diff --git a/latex-test/accept.lhs b/latex-test/accept.lhs deleted file mode 100755 index 4d0b0127..00000000 --- a/latex-test/accept.lhs +++ /dev/null @@ -1,46 +0,0 @@ -#!/usr/bin/env runhaskell -\begin{code} -{-# LANGUAGE CPP #-} -import System.Environment -import System.FilePath -import System.Directory -import Data.List -import Control.Applicative -import Control.Monad - -baseDir :: FilePath -baseDir = takeDirectory __FILE__ - -main :: IO () -main = do - contents <- filter (not . ignore) <$> getDirectoryContents (baseDir </> "out") - args <- getArgs - mapM_ copyDir $ if not (null args) - then filter ((`elem` args) . takeBaseName) contents - else contents - where - ignore = - foldr (liftA2 (||)) (const False) [ - (== ".") - , (== "..") - , isPrefixOf "index" - , isPrefixOf "doc-index" - ] - --- | Copy a directory to ref, one level deep. -copyDir :: FilePath -> IO () -copyDir dir = do - let old = baseDir </> "out" </> dir - new = baseDir </> "ref" </> dir - alreadyExists <- doesDirectoryExist new - unless alreadyExists $ do - putStrLn (old ++ " -> " ++ new) - createDirectoryIfMissing True new - files <- getDirectoryContents old >>= filterM (liftM not . doesDirectoryExist) - let files' = filter (\x -> x /= "." && x /= "..") files - mapM_ (\f -> copyFile' (old </> f) (new </> f)) files' - where - copyFile' o n = do - putStrLn $ o ++ " -> " ++ n - copyFile o n -\end{code} diff --git a/latex-test/ref/Simple/Simple.tex b/latex-test/ref/Simple/Simple.tex index 89e849f8..5ba4712c 100644 --- a/latex-test/ref/Simple/Simple.tex +++ b/latex-test/ref/Simple/Simple.tex @@ -11,7 +11,6 @@ module Simple ( \item[\begin{tabular}{@{}l} foo\ ::\ t \end{tabular}]\haddockbegindoc -This is foo. -\par +This is foo.\par \end{haddockdesc}
\ No newline at end of file diff --git a/latex-test/run b/latex-test/run new file mode 100755 index 00000000..3e72be80 --- /dev/null +++ b/latex-test/run @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +export HADDOCK_PATH=$(which haddock) +LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" +MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" +runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ diff --git a/latex-test/run.lhs b/latex-test/run.lhs deleted file mode 100755 index d3e39e90..00000000 --- a/latex-test/run.lhs +++ /dev/null @@ -1,162 +0,0 @@ -#!/usr/bin/env runhaskell -\begin{code} -{-# LANGUAGE CPP #-} -import Prelude hiding (mod) -import Control.Monad -import Control.Applicative -import Data.List -import Data.Maybe -import Distribution.InstalledPackageInfo hiding (dataDir) -import Distribution.Package (PackageName (..)) -import Distribution.Simple.Compiler -import Distribution.Simple.GHC -import Distribution.Simple.PackageIndex -import Distribution.Simple.Program -import Distribution.Simple.Utils -import Distribution.Verbosity -import System.IO -import System.Directory -import System.Environment -import System.Exit -import System.FilePath -import System.Process (ProcessHandle, runProcess, waitForProcess, system) - - -packageRoot, dataDir, haddockPath, baseDir, testDir, outDir, refDir :: FilePath -baseDir = takeDirectory __FILE__ -testDir = baseDir </> "src" -refDir = baseDir </> "ref" -outDir = baseDir </> "out" -packageRoot = baseDir </> ".." -dataDir = packageRoot </> "resources" -haddockPath = packageRoot </> "dist" </> "build" </> "haddock" </> "haddock" - - -main :: IO () -main = do - test - putStrLn "All tests passed!" - - -test :: IO () -test = do - x <- doesFileExist haddockPath - unless x $ System.Exit.die "you need to run 'cabal build' successfully first" - - contents <- getDirectoryContents testDir - - args <- getArgs - let (opts, spec) = span ("-" `isPrefixOf`) args - isDir x' = liftM2 (&&) (doesDirectoryExist $ testDir </> x') - (return $ x' /= "." && x' /= "..") - modDirs <- case spec of - y:_ | y /= "all" -> return [y] - _ -> filterM isDir contents - - let modDirs' = map (testDir </>) modDirs - - -- add haddock_datadir to environment for subprocesses - env <- Just . (:) ("haddock_datadir", dataDir) <$> getEnvironment - - putStrLn "" - putStrLn "Haddock version: " - h1 <- runProcess haddockPath ["--version"] Nothing - env Nothing Nothing Nothing - wait h1 "*** Running `haddock --version' failed!" - putStrLn "" - putStrLn "GHC version: " - h2 <- runProcess haddockPath ["--ghc-version"] Nothing - env Nothing Nothing Nothing - wait h2 "*** Running `haddock --ghc-version' failed!" - putStrLn "" - - -- TODO: maybe do something more clever here using haddock.cabal - ghcPath <- fmap init $ rawSystemStdout normal haddockPath ["--print-ghc-path"] - (_, _, conf) <- configure normal (Just ghcPath) Nothing defaultProgramConfiguration - pkgIndex <- getInstalledPackages normal [GlobalPackageDB] conf - let mkDep pkgName = - fromMaybe (error "Couldn't find test dependencies") $ do - let pkgs = lookupPackageName pkgIndex (PackageName pkgName) - (_, pkgs') <- listToMaybe pkgs - pkg <- listToMaybe pkgs' - ifacePath <- listToMaybe (haddockInterfaces pkg) - htmlPath <- listToMaybe (haddockHTMLs pkg) - return ("-i " ++ htmlPath ++ "," ++ ifacePath) - - let base = mkDep "base" - process = mkDep "process" - ghcprim = mkDep "ghc-prim" - - putStrLn "Running tests..." - - forM_ modDirs' $ \modDir -> do - testModules <- getDirectoryContents modDir - - let mods = filter ((==) ".hs" . takeExtension) testModules - mods' = map (modDir </>) mods - - unless (null mods') $ do - handle <- runProcess haddockPath - (["-w", "-o", outDir </> last (splitPath modDir), "--latex" - , "--optghc=-fglasgow-exts" - , "--optghc=-w", base, process, ghcprim] ++ opts ++ mods') - Nothing env Nothing - Nothing Nothing - - wait handle "*** Haddock run failed! Exiting." - - check modDirs (if not (null args) && args !! 0 == "all" then False else True) - where - wait :: ProcessHandle -> String -> IO () - wait h msg = do - r <- waitForProcess h - unless (r == ExitSuccess) $ do - hPutStrLn stderr msg - exitFailure - -check :: [FilePath] -> Bool -> IO () -check modDirs strict = do - forM_ modDirs $ \modDir -> do - let oDir = outDir </> modDir - rDir = refDir </> modDir - - refDirExists <- doesDirectoryExist rDir - when refDirExists $ do - -- we're not creating sub-directories, I think. - refFiles <- getDirectoryContents rDir >>= filterM doesFileExist - - forM_ refFiles $ \rFile -> do - let refFile = rDir </> rFile - outFile = oDir </> rFile - oe <- doesFileExist outFile - if oe - then do - out <- readFile outFile - ref <- readFile refFile - - if out /= ref - then do - putStrLn $ "Output for " ++ modDir ++ " has changed! Exiting with diff:" - - let reffile' = outDir </> takeFileName refFile ++ ".nolinks" - outfile' = outDir </> takeFileName outFile ++ ".ref.nolinks" - writeFile reffile' ref - writeFile outfile' out - r <- programOnPath "colordiff" - code <- if r - then system $ "colordiff " ++ reffile' ++ " " ++ outfile' - else system $ "diff " ++ reffile' ++ " " ++ outfile' - if strict then exitFailure else return () - unless (code == ExitSuccess) $ do - hPutStrLn stderr "*** Running diff failed!" - exitFailure - else do - putStrLn $ "Pass: " ++ modDir - else do - putStrLn $ "Pass: " ++ modDir ++ " (no .ref file)" - -programOnPath :: FilePath -> IO Bool -programOnPath p = do - result <- findProgramLocation silent p - return (isJust result) -\end{code} |