diff options
28 files changed, 1219 insertions, 250 deletions
diff --git a/.travis.yml b/.travis.yml index 681399b9..2bcb301a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,8 +1,8 @@ # This Travis job script has been generated by a script via # -# runghc make_travis_yml_2.hs 'haddock.cabal' +# make_travis_yml_2.hs 'haddock.cabal' # -# For more information, see https://github.com/haskell-CI/haskell-ci +# For more information, see https://github.com/hvr/multi-ghc-travis # language: c sudo: false @@ -28,63 +28,70 @@ before_cache: matrix: include: - - compiler: "ghc-8.6.1" + - compiler: "ghc-head" + env: GHCHEAD=true # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.6.1], sources: [hvr-ghc]}} + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}} before_install: - - HC=${CC} - - HCPKG=${HC/ghc/ghc-pkg} - - unset CC - - ROOTDIR=$(pwd) - - mkdir -p $HOME/.local/bin - - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" - - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) - - echo $HCNUMVER + - HC=${CC} + - HCPKG=${HC/ghc/ghc-pkg} + - unset CC + - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH + - PKGNAME='haddock' install: - - cabal --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - BENCH=${BENCH---enable-benchmarks} - - TEST=${TEST---enable-tests} - - HADDOCK=${HADDOCK-true} - - UNCONSTRAINED=${UNCONSTRAINED-true} - - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false} - - GHCHEAD=${GHCHEAD-false} - - travis_retry cabal update -v - - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" - - rm -fv cabal.project.local - - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - - touch cabal.project.local - - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- haddock | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" - - cat cabal.project || true - - cat cabal.project.local || true - - if [ -f "./configure.ac" ]; then - (cd "." && autoreconf -i); - fi - - rm -f cabal.project.freeze - - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all - - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all - - rm -rf .ghc.environment.* "."/dist - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) + - cabal --version + - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" + - BENCH=${BENCH---enable-benchmarks} + - TEST=${TEST---enable-tests} + - GHCHEAD=${GHCHEAD-false} + - travis_retry cabal update -v + - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config + - rm -fv cabal.project.local + - rm -f cabal.project.freeze + # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage + - | + if $GHCHEAD; then + sed -i 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config + for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" ${HOME}/.cabal/config; done + + echo 'repository head.hackage' >> ${HOME}/.cabal/config + echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config + echo ' secure: True' >> ${HOME}/.cabal/config + echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config + echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config + echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config + echo ' key-threshold: 3' >> ${HOME}/.cabal.config + + grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' + + cabal new-update head.hackage -v + fi + - travis_retry cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 --allow-newer --constraint 'setup.Cabal installed' all + - travis_retry cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 --allow-newer --constraint 'setup.Cabal installed' all # Here starts the actual work to be performed for the package under test; # any command which exits with a non-zero exit code causes the build to fail. script: - - cat cabal.project || true - - cat cabal.project.local || true - # this builds all libraries and executables (without tests/benchmarks) - - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all - - # build & run tests, build benchmarks - - cabal new-build -w ${HC} ${TEST} ${BENCH} all - - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi - - # cabal check - - cabal check + - if [ -f configure.ac ]; then autoreconf -i; fi + - rm -rf dist/ + - cabal sdist # test that a source-distribution can be generated + - cd dist/ + - SRCTAR=(${PKGNAME}-*.tar.gz) + - SRC_BASENAME="${SRCTAR/%.tar.gz}" + - tar -xvf "./$SRC_BASENAME.tar.gz" + - cd "$SRC_BASENAME/" +## from here on, CWD is inside the extracted source-tarball + - rm -fv cabal.project.local + # this builds all libraries and executables (without tests/benchmarks) + - rm -f cabal.project.freeze + - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --allow-newer --constraint 'setup.Cabal installed' all + # this builds all libraries and executables (including tests/benchmarks) + # - rm -rf ./dist-newstyle - # Build without installed constraints for packages in global-db - - if $UNCONSTRAINED; then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi + # build & run tests + - cabal new-build -w ${HC} ${TEST} ${BENCH} --allow-newer --constraint 'setup.Cabal installed' all + - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} --allow-newer --constraint 'setup.Cabal installed' all; fi -# REGENDATA ["haddock.cabal"] # EOF @@ -1,4 +1,4 @@ -# Haddock, a Haskell Documentation Tool [](https://travis-ci.org/haskell/haddock) +# Haddock, a Haskell Documentation Tool [](https://travis-ci.org/haskell/haddock) ## About haddock @@ -57,9 +57,9 @@ and then proceed using your favourite build tool. #### Using [`cabal new-build`](http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html) ```bash -cabal new-build -w ghc-8.6.1 +cabal new-build -w ghc-head # build & run the test suite -cabal new-test -w ghc-8.6.1 all +cabal new-test -w ghc-head all ``` #### Using Cabal sandboxes diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index fa14eb50..c262f975 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -42,7 +42,7 @@ library -- this package typically supports only single major versions build-depends: base ^>= 4.12.0 , Cabal ^>= 2.4.0 - , ghc ^>= 8.6 + , ghc ^>= 8.7 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.7.0 , xhtml ^>= 3000.2.2 @@ -167,7 +167,7 @@ test-suite spec Haddock.Backends.Hyperlinker.Types build-depends: Cabal ^>= 2.4 - , ghc ^>= 8.6 + , ghc ^>= 8.7 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.7.0 , xhtml ^>= 3000.2.2 diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index dbfba0f4..8c0ae705 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -161,16 +161,21 @@ haddockWithGhc ghc args = handleTopExceptions $ do Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags _ -> return flags + -- bypass the interface version check + let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags + unless (Flag_NoWarnings `elem` flags) $ do hypSrcWarnings flags forM_ (warnings args) $ \warning -> do hPutStrLn stderr warning + when noChecks $ + hPutStrLn stderr noCheckWarning ghc flags' $ do dflags <- getDynFlags forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do - mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] + mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks forM_ mIfaceFile $ \(_, ifaceFile) -> do putMsg dflags (renderJson (jsonInterfaceFile ifaceFile)) @@ -192,7 +197,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do throwE "No input file(s)." -- Get packages supplied with --read-interface. - packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) + packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). liftIO $ renderStep dflags flags sinceQual qual packages [] @@ -203,6 +208,10 @@ warnings = map format . filter (isPrefixOf "-optghc") where format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"] +-- | Create a warning about bypassing the interface version check +noCheckWarning :: String +noCheckWarning = "Warning: `--bypass-interface-version-check' can cause " ++ + "Haddock to crash when reading Haddock interface files." withGhc :: [Flag] -> Ghc a -> IO a withGhc flags action = do @@ -220,7 +229,8 @@ readPackagesAndProcessModules :: [Flag] -> [String] -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) readPackagesAndProcessModules flags files = do -- Get packages supplied with --read-interface. - packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) + let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags + packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks -- Create the interfaces -- this is the core part of Haddock. let ifaceFiles = map snd packages @@ -404,13 +414,14 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do readInterfaceFiles :: MonadIO m => NameCacheAccessor m -> [(DocPaths, FilePath)] + -> Bool -> m [(DocPaths, InterfaceFile)] -readInterfaceFiles name_cache_accessor pairs = do +readInterfaceFiles name_cache_accessor pairs bypass_version_check = do catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs where -- try to read an interface, warn if we can't tryReadIface (paths, file) = - readInterfaceFile name_cache_accessor file >>= \case + readInterfaceFile name_cache_accessor file bypass_version_check >>= \case Left err -> liftIO $ do putStrLn ("Warning: Cannot read " ++ file ++ ":") putStrLn (" " ++ err) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index acb2c892..f8494242 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -144,7 +144,7 @@ spanToNewline 0 str@(c:_) | ((lexed, str') : _) <- R.lex str, not (isSpace c) = -- A Haskell line comment then case span (/= '\n') str' of (str'', '\n':rest) -> (lexed ++ str'' ++ "\n", rest) - (_, _) -> (str, "") + (_, _) -> (str, "") -- An actual Haskell token else let (str'', rest) = spanToNewline 0 str' @@ -165,10 +165,10 @@ ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False) go :: (RealSrcLoc, [T.Token], Bool) -- ^ current position, tokens accumulated, currently in pragma (or not) - + -> (Located L.Token, String) -- ^ next token, its content - + -> (RealSrcLoc, [T.Token], Bool) -- ^ new position, new tokens accumulated, currently in pragma (or not) @@ -179,12 +179,12 @@ ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False) ) where (next_pos, white) = mkWhitespace pos l - + classifiedTok = [ Token (classify' tok) raw rss | RealSrcSpan rss <- [l] , not (null raw) ] - + classify' | in_prag = const TkPragma | otherwise = classify @@ -378,6 +378,7 @@ classify tok = ITLarrowtail {} -> TkGlyph ITRarrowtail {} -> TkGlyph + ITcomment_line_prag -> TkUnknown ITunknown {} -> TkUnknown ITeof -> TkUnknown diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 4a3e9d03..0c7747bd 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -12,10 +12,9 @@ -- Portability : portable ----------------------------------------------------------------------------- module Haddock.Backends.LaTeX ( - ppLaTeX + ppLaTeX, ) where - import Documentation.Haddock.Markup import Haddock.Types import Haddock.Utils @@ -285,7 +284,7 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print -> LaTeX ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of - TyClD _ d@FamDecl {} -> ppTyFam False doc d unicode + TyClD _ d@FamDecl {} -> ppFamDecl doc instances d unicode TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now @@ -303,12 +302,6 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of unicode = False -ppTyFam :: Bool -> Documentation DocName -> - TyClDecl DocNameI -> Bool -> LaTeX -ppTyFam _ _ _ _ = - error "type family declarations are currently not supported by --latex" - - ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode = ppFunSig doc [name] (hsSigType typ) unicode @@ -317,6 +310,83 @@ ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" ------------------------------------------------------------------------------- +-- * Type families +------------------------------------------------------------------------------- + +-- | Pretty-print a data\/type family declaration +ppFamDecl :: Documentation DocName -- ^ this decl's docs + -> [DocInstance DocNameI] -- ^ relevant instances + -> TyClDecl DocNameI -- ^ family to print + -> Bool -- ^ unicode + -> LaTeX +ppFamDecl doc instances decl unicode = + declWithDoc (ppFamHeader (tcdFam decl) unicode <+> whereBit) + (if null body then Nothing else Just (vcat body)) + $$ instancesBit + where + body = catMaybes [familyEqns, documentationToLaTeX doc] + + whereBit = case fdInfo (tcdFam decl) of + ClosedTypeFamily _ -> keyword "where" + _ -> empty + + familyEqns + | FamilyDecl { fdInfo = ClosedTypeFamily (Just eqns) } <- tcdFam decl + = Just (text "\\haddockbeginargs" $$ + vcat [ decltt (ppFamDeclEqn eqn) <+> nl | L _ eqn <- eqns ] $$ + text "\\end{tabulary}\\par") + | otherwise = Nothing + + -- Individual equations of a closed type family + ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX + ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n + , feqn_rhs = rhs + , feqn_pats = ts } }) + = hsep [ ppAppNameTypes n (map unLoc ts) unicode + , equals + , ppType unicode (unLoc rhs) + ] + ppFamDeclEqn (XHsImplicitBndrs _) = panic "haddock:ppFamDecl" + ppFamDeclEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppFamDecl" + + instancesBit = ppDocInstances unicode instances + +-- | Print the LHS of a type\/data family declaration. +ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print + -> Bool -- ^ unicode + -> LaTeX +ppFamHeader (XFamilyDecl _) _ = panic "haddock;ppFamHeader" +ppFamHeader (FamilyDecl { fdLName = L _ name + , fdTyVars = tvs + , fdInfo = info + , fdResultSig = L _ result + , fdInjectivityAnn = injectivity }) + unicode = + leader <+> keyword "family" <+> famName <+> famSig <+> injAnn + where + leader = case info of + OpenTypeFamily -> keyword "type" + ClosedTypeFamily _ -> keyword "type" + DataFamily -> keyword "data" + + famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs) + + famSig = case result of + NoSig _ -> empty + KindSig _ kind -> dcolon unicode <+> ppLKind unicode kind + TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode bndr + XFamilyResultSig _ -> panic "haddock:ppFamHeader" + + injAnn = case injectivity of + Nothing -> empty + Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( decltt (text "|") + : ppLDocName lhs + : arrow unicode + : map ppLDocName rhs) + + + +------------------------------------------------------------------------------- -- * Type Synonyms ------------------------------------------------------------------------------- @@ -538,12 +608,14 @@ ppClassDecl instances doc subdocs | otherwise = error "LaTeX.ppClassDecl" methodTable = - text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig doc [name] (hsSigWcType typ) unicode + text "\\haddockpremethods{}" <> emph (text "Methods") $$ + vcat [ ppFunSig doc names (hsSigWcType typ) unicode | L _ (TypeSig _ lnames typ) <- lsigs - , name <- map unLoc lnames - , let doc = lookupAnySubdoc name subdocs - ] + , let doc = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames ] + -- FIXME: is taking just the first name ok? Is it possible that + -- there are different subdocs for different names in a single + -- type signature? instancesBit = ppDocInstances unicode instances @@ -573,14 +645,13 @@ ppDocInstance unicode (instHead, doc, _, _) = ppInstDecl :: Bool -> InstHead DocNameI -> LaTeX -ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead - - -ppInstHead :: Bool -> InstHead DocNameI -> LaTeX -ppInstHead unicode (InstHead {..}) = case ihdInstType of - ClassInst ctx _ _ _ -> ppContextNoLocs ctx unicode <+> typ - TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs - DataInst _ -> error "data instances not supported by --latex yet" +ppInstDecl unicode (InstHead {..}) = case ihdInstType of + ClassInst ctx _ _ _ -> keyword "instance" <+> ppContextNoLocs ctx unicode <+> typ + TypeInst rhs -> keyword "type" <+> keyword "instance" <+> typ <+> tibody rhs + DataInst dd -> + let nd = dd_ND (tcdDataDefn dd) + pref = case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" } + in pref <+> keyword "instance" <+> typ where typ = ppAppNameTypes ihdClsName ihdTypes unicode tibody = maybe empty (\t -> equals <+> ppType unicode t) @@ -613,7 +684,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode = cons = dd_cons (tcdDataDefn dataDecl) resTy = (unLoc . head) cons - body = catMaybes [constrBit,patternBit, doc >>= documentationToLaTeX] + body = catMaybes [doc >>= documentationToLaTeX, constrBit,patternBit] (whereBit, leaders) | null cons @@ -823,6 +894,12 @@ ppDataHeader _ _ = error "ppDataHeader: illegal argument" -- * Type applications -------------------------------------------------------------------------------- +ppAppDocNameTyVarBndrs :: Bool -> DocName -> [LHsTyVarBndr DocNameI] -> LaTeX +ppAppDocNameTyVarBndrs unicode n vs = + ppTypeApp n vs ppDN (ppHsTyVarBndr unicode . unLoc) + where + ppDN = ppBinder . nameOccName . getName + -- | Print an application of a DocName to its list of HsTypes ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX @@ -897,7 +974,7 @@ tupleParens _ = parenList sumParens :: [LaTeX] -> LaTeX -sumParens = ubxparens . hsep . punctuate (text " | ") +sumParens = ubxparens . hsep . punctuate (text " |") ------------------------------------------------------------------------------- @@ -917,6 +994,12 @@ ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode +ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX +ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name +ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) = + parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind +ppHsTyVarBndr _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr" + ppLKind :: Bool -> LHsKind DocNameI -> LaTeX ppLKind unicode y = ppKind unicode (unLoc y) @@ -973,7 +1056,7 @@ ppr_mono_ty (HsParTy _ ty) unicode ppr_mono_ty (HsDocTy _ ty _) unicode = ppr_mono_lty ty unicode -ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = char '_' +ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = text "\\_" ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) @@ -1252,7 +1335,7 @@ ubxParenList = ubxparens . hsep . punctuate comma ubxparens :: LaTeX -> LaTeX -ubxparens h = text "(#" <> h <> text "#)" +ubxparens h = text "(#" <+> h <+> text "#)" nl :: LaTeX diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index cc271fef..12e65716 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -15,9 +15,7 @@ ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Decl ( ppDecl, - - ppTyName, ppTyFamHeader, ppTypeApp, ppOrphanInstances, - tyvarNames + ppOrphanInstances, ) where import Haddock.Backends.Xhtml.DocMarkup @@ -56,7 +54,7 @@ ppDecl :: Bool -- ^ print summary info only -> Qualification -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of - TyClD _ (FamDecl _ d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual + TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities loc mbDoc d splice unicode pkg qual TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual @@ -67,7 +65,7 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual InstD _ _ -> noHtml DerivD _ _ -> noHtml - _ -> error "declaration not supported by ppDecl" + _ -> error "declaration not supported by ppDecl" ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> @@ -222,9 +220,6 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> [Html] ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs -tyvarNames :: LHsQTyVars DocNameI -> [Name] -tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit - ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> [(DocName, Fixity)] @@ -283,111 +278,111 @@ ppSimpleSig links splice unicode qual emptyCtxts loc names typ = -------------------------------------------------------------------------------- -ppFamilyInfo :: Bool -> FamilyInfo DocNameI -> Html -ppFamilyInfo assoc OpenTypeFamily - | assoc = keyword "type" - | otherwise = keyword "type family" -ppFamilyInfo assoc DataFamily - | assoc = keyword "data" - | otherwise = keyword "data family" -ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family" - - -ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocNameI - -> Unicode -> Qualification -> Html -ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info - , fdResultSig = L _ result - , fdInjectivityAnn = injectivity }) - unicode qual = - (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 unicode qual d <+> - ppResultSig result unicode qual <+> - - (case injectivity of - Nothing -> noHtml - Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn - ) <+> - - (case info of - ClosedTypeFamily _ -> keyword "where ..." - _ -> mempty - ) -ppTyFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppTyFamHeader" - -ppResultSig :: FamilyResultSig DocNameI -> 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 - XFamilyResultSig _ -> panic "haddock:ppResultSig" - -ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI - -> Html -ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) = - ppFamilyInfo True pfdInfo <+> - ppAppNameTypes (unLoc pfdLName) (map unLoc pfdTyVars) unicode qual <+> - ppResultSig (unLoc pfdKindSig) unicode qual - -ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocNameI -> 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 DocNameI] -> - [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> - FamilyDecl DocNameI -> Splice -> Unicode -> Maybe Package -> - Qualification -> Html -ppTyFam summary associated links instances fixities loc doc decl splice unicode - pkg qual - - | summary = ppTyFamHeader True associated decl unicode qual +-- | Print a data\/type family declaration +ppFamDecl :: Bool -- ^ is a summary + -> Bool -- ^ is an associated type + -> LinksInfo + -> [DocInstance DocNameI] -- ^ relevant instances + -> [(DocName, Fixity)] -- ^ relevant fixities + -> SrcSpan + -> Documentation DocName -- ^ this decl's documentation + -> FamilyDecl DocNameI -- ^ this decl + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppFamDecl summary associated links instances fixities loc doc decl splice unicode pkg qual + | summary = ppFamHeader True associated decl unicode qual | otherwise = header_ +++ docSection Nothing pkg qual doc +++ instancesBit where docname = unLoc $ fdLName decl header_ = topDeclElem links loc splice [docname] $ - ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual + ppFamHeader summary associated decl unicode qual <+> ppFixities fixities qual instancesBit | FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl , not summary - = subEquations pkg qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns + = subEquations pkg qual $ map (ppFamDeclEqn . unLoc) $ fromMaybe [] mb_eqns | otherwise = ppInstances links (OriginFamily docname) instances splice unicode pkg qual -- Individual equation of a closed type family - ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl - ppTyFamEqn (HsIB { hsib_body = FamEqn { feqn_tycon = n, feqn_rhs = rhs - , feqn_pats = ts } }) - = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual + ppFamDeclEqn :: TyFamInstEqn DocNameI -> SubDecl + ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n + , feqn_rhs = rhs + , feqn_pats = ts } }) + = ( ppAppNameTypes n (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) - , Nothing, [] ) - ppTyFamEqn (XHsImplicitBndrs _) = panic "haddock:ppTyFam" - ppTyFamEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppTyFam" - + , Nothing + , [] + ) + ppFamDeclEqn (XHsImplicitBndrs _) = panic "haddock:ppFamDecl" + ppFamDeclEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppFamDecl" -ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification - -> PseudoFamilyDecl DocNameI - -> Html -ppPseudoFamilyDecl links splice unicode qual - decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) = - wrapper $ ppPseudoFamilyHeader unicode qual decl +-- | Print a pseudo family declaration +ppPseudoFamDecl :: LinksInfo -> Splice + -> PseudoFamilyDecl DocNameI -- ^ this decl + -> Unicode -> Qualification -> Html +ppPseudoFamDecl links splice + (PseudoFamilyDecl { pfdInfo = info + , pfdKindSig = L _ kindSig + , pfdTyVars = tvs + , pfdLName = L loc name }) + unicode qual = + topDeclElem links loc splice [name] leader + where + leader = hsep [ ppFamilyLeader True info + , ppAppNameTypes name (map unLoc tvs) unicode qual + , ppResultSig kindSig unicode qual + ] + +-- | Print the LHS of a type\/data family declaration +ppFamHeader :: Bool -- ^ is a summary + -> Bool -- ^ is an associated type + -> FamilyDecl DocNameI -- ^ family declaration + -> Unicode -> Qualification -> Html +ppFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppFamHeader" +ppFamHeader summary associated (FamilyDecl { fdInfo = info + , fdResultSig = L _ result + , fdInjectivityAnn = injectivity + , fdLName = L _ name + , fdTyVars = tvs }) + unicode qual = + hsep [ ppFamilyLeader associated info + , ppAppDocNameTyVarBndrs summary unicode qual name (hsq_explicit tvs) + , ppResultSig result unicode qual + , injAnn + , whereBit + ] where - wrapper = topDeclElem links loc splice [name] + whereBit = case info of + ClosedTypeFamily _ -> keyword "where ..." + _ -> noHtml + + injAnn = case injectivity of + Nothing -> noHtml + Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( keyword "|" + : ppLDocName qual Raw lhs + : arrow unicode + : map (ppLDocName qual Raw) rhs) + +-- | Print the keywords that begin the family declaration +ppFamilyLeader :: Bool -> FamilyInfo DocNameI -> Html +ppFamilyLeader assoc info = keyword (typ ++ if assoc then "" else " family") + where + typ = case info of + OpenTypeFamily -> "type" + ClosedTypeFamily _ -> "type" + DataFamily -> "data" + +-- | Print the signature attached to a family +ppResultSig :: FamilyResultSig DocNameI -> 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 + XFamilyResultSig _ -> panic "haddock:ppResultSig" -------------------------------------------------------------------------------- @@ -399,25 +394,10 @@ ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual = - ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode pkg qual + ppFamDecl summ True links [] fixities loc (fst doc) decl splice unicode pkg qual -------------------------------------------------------------------------------- --- * TyClDecl helpers --------------------------------------------------------------------------------- - --- | Print a type family and its variables -ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html -ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = - ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs) -ppFamDeclBinderWithVars _ _ _ (XFamilyDecl _) = panic "haddock:ppFamDeclBinderWithVars" - --- | Print a newtype / data binder and its variables -ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html -ppDataBinderWithVars summ unicode qual decl = - ppAppDocNameTyVarBndrs summ unicode qual (tcdName decl) (hsQTvExplicit $ tcdTyVars decl) - --------------------------------------------------------------------------------- -- * Type applications -------------------------------------------------------------------------------- @@ -672,7 +652,9 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) m , mdoc , [subFamInstDetails iid pdecl mname]) where - pdata = keyword "data" <+> typ + nd = dd_ND (tcdDataDefn dd) + pref = case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" } + pdata = pref <+> typ pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual where mname = maybe noHtml (\m -> toHtml "Defined in" <+> ppModule m) mdl @@ -684,9 +666,7 @@ ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification -> [PseudoFamilyDecl DocNameI] -> [Html] ppInstanceAssocTys links splice unicode qual = - map ppFamilyDecl' - where - ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual + map (\pseudo -> ppPseudoFamDecl links splice pseudo unicode qual) ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification @@ -1060,10 +1040,12 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) = -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html -ppDataHeader summary decl@(DataDecl { tcdDataDefn = - HsDataDefn { dd_ND = nd - , dd_ctxt = ctxt - , dd_kindSig = ks } }) +ppDataHeader summary (DataDecl { tcdDataDefn = + HsDataDefn { dd_ND = nd + , dd_ctxt = ctxt + , dd_kindSig = ks } + , tcdLName = L _ name + , tcdTyVars = tvs }) unicode qual = -- newtype or data (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) @@ -1071,7 +1053,7 @@ ppDataHeader summary decl@(DataDecl { tcdDataDefn = -- context ppLContext ctxt unicode qual HideEmptyContexts <+> -- T a b c ..., or a :+: b - ppDataBinderWithVars summary unicode qual decl + ppAppDocNameTyVarBndrs summary unicode qual name (hsQTvExplicit tvs) <+> case ks of Nothing -> mempty Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x @@ -1120,7 +1102,7 @@ ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) = ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) = parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> ppLKind unicode qual kind) -ppHsTyVarBndr _ _ (XTyVarBndr _) = error "haddock:ppHsTyVarBndr" +ppHsTyVarBndr _ _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr" ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index 7fbaec6d..62781fd0 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -183,7 +183,7 @@ ubxSumList = ubxparens . hsep . punctuate (toHtml " | ") ubxparens :: Html -> Html -ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" +ubxparens h = toHtml "(#" <+> h <+> toHtml "#)" dcolon, arrow, darrow, forallSymbol :: Bool -> Html diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 6eee353b..f8c26175 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -36,9 +36,10 @@ import TyCon import Type import TyCoRep import TysPrim ( alphaTyVars ) -import TysWiredIn ( listTyConName, liftedTypeKindTyConName, unitTy ) -import PrelNames ( hasKey, eqTyConKey, eqTyConName, ipClassKey - , tYPETyConKey, liftedRepDataConKey ) +import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName + , unitTy, promotedNilDataCon, promotedConsDataCon ) +import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey + , liftedRepDataConKey ) import Unique ( getUnique ) import Util ( chkAppend, compareLength, dropList, filterByList, filterOut , splitAtList ) @@ -118,8 +119,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) args_types_only typats hs_rhs = synifyType WithinType rhs - in HsIB { hsib_ext = HsIBRn { hsib_vars = map tyVarName tkvs - , hsib_closed = True } + in HsIB { hsib_ext = map tyVarName tkvs , hsib_body = FamEqn { feqn_ext = noExt , feqn_tycon = name , feqn_pats = annot_typats @@ -457,9 +457,24 @@ synifyType _ (TyConApp tc tys) ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) (map (synifyType WithinType) vis_tys) + | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType) vis_tys) + | Just dc <- isPromotedDataCon_maybe tc + , isTupleDataCon dc + , dataConSourceArity dc == length vis_tys + = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType) vis_tys) -- ditto for lists - | getName tc == listTyConName, [ty] <- tys = + | getName tc == listTyConName, [ty] <- vis_tys = noLoc $ HsListTy noExt (synifyType WithinType ty) + | tc == promotedNilDataCon, [] <- vis_tys + = noLoc $ HsExplicitListTy noExt Promoted [] + | tc == promotedConsDataCon + , [ty1, ty2] <- vis_tys + = let hTy = synifyType WithinType ty1 + in case synifyType WithinType ty2 of + tTy | L _ (HsExplicitListTy _ Promoted tTy') <- stripKindSig tTy + -> noLoc $ HsExplicitListTy noExt Promoted (hTy : tTy') + | otherwise + -> noLoc $ HsOpTy noExt hTy (noLoc $ getName tc) tTy -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys @@ -567,6 +582,10 @@ synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s synifyKindSig :: Kind -> LHsKind GhcRn synifyKindSig k = synifyType WithinType k +stripKindSig :: LHsType GhcRn -> LHsType GhcRn +stripKindSig (L _ (HsKindSig _ t _)) = t +stripKindSig t = t + synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead { ihdClsName = getName cls @@ -652,8 +671,8 @@ tcSplitSigmaTyPreserveSynonyms ty = tcSplitForAllTysPreserveSynonyms :: Type -> ([TyVar], Type) tcSplitForAllTysPreserveSynonyms ty = split ty ty [] where - split _ (ForAllTy (TvBndr tv _) ty') tvs = split ty' ty' (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) + split _ (ForAllTy (Bndr tv _) ty') tvs = split ty' ty' (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) -- | See Note [Invariant: Never expand type synonyms] tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 1c976410..351a39d1 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -23,7 +23,7 @@ import GHC hiding (NoLink) import Name import Outputable ( panic ) import RdrName (RdrName(Exact)) -import PrelNames (eqTyCon_RDR) +import TysWiredIn (eqTyCon_RDR) import Control.Applicative import Control.Monad hiding (mapM) diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index ce6ecc78..30bd2b9a 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -82,7 +82,7 @@ binaryInterfaceMagic = 0xD0Cface -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if (__GLASGOW_HASKELL__ >= 805) && (__GLASGOW_HASKELL__ < 807) +#if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809) binaryInterfaceVersion = 33 binaryInterfaceVersionCompatibility :: [Word16] @@ -190,8 +190,9 @@ readInterfaceFile :: forall m. MonadIO m => NameCacheAccessor m -> FilePath + -> Bool -- ^ Disable version check. Can cause runtime crash. -> m (Either String InterfaceFile) -readInterfaceFile (get_name_cache, set_name_cache) filename = do +readInterfaceFile (get_name_cache, set_name_cache) filename bypass_checks = do bh0 <- liftIO $ readBinMem filename magic <- liftIO $ get bh0 @@ -200,7 +201,8 @@ readInterfaceFile (get_name_cache, set_name_cache) filename = do case () of _ | magic /= binaryInterfaceMagic -> return . Left $ "Magic number mismatch: couldn't load interface file: " ++ filename - | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $ + | not bypass_checks + , (version `notElem` binaryInterfaceVersionCompatibility) -> return . Left $ "Interface file is of wrong version: " ++ filename | otherwise -> with_name_cache $ \update_nc -> do diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index b5e987d8..46db572b 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -84,6 +84,7 @@ data Flag | Flag_Version | Flag_CompatibleInterfaceVersions | Flag_InterfaceVersion + | Flag_BypassInterfaceVersonCheck | Flag_UseContents String | Flag_GenContents | Flag_UseIndex String @@ -175,6 +176,8 @@ options backwardsCompat = "output compatible interface file versions and exit", Option [] ["interface-version"] (NoArg Flag_InterfaceVersion) "output interface file version and exit", + Option [] ["bypass-interface-version-check"] (NoArg Flag_BypassInterfaceVersonCheck) + "bypass the interface file version check (dangerous)", Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY") "set verbosity level", Option [] ["use-contents"] (ReqArg Flag_UseContents "URL") @@ -186,7 +189,7 @@ options backwardsCompat = Option [] ["gen-index"] (NoArg Flag_GenIndex) "generate an HTML index from specified\ninterfaces", Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports) - "behave as if all modules have the\nignore-exports atribute", + "behave as if all modules have the\nignore-exports attribute", Option [] ["hide"] (ReqArg Flag_HideModule "MODULE") "behave as if MODULE has the hide attribute", Option [] ["show"] (ReqArg Flag_ShowModule "MODULE") diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs index 942c0587..25c64cfe 100644 --- a/haddock-test/src/Test/Haddock.hs +++ b/haddock-test/src/Test/Haddock.hs @@ -34,12 +34,12 @@ data CheckResult runAndCheck :: Config c -> IO () runAndCheck cfg = do - runHaddock cfg - checkFiles cfg + crashed <- runHaddock cfg + checkFiles cfg crashed -checkFiles :: Config c -> IO () -checkFiles cfg@(Config { .. }) = do +checkFiles :: Config c -> Bool -> IO () +checkFiles cfg@(Config { .. }) somethingCrashed = do putStrLn "Testing output files..." files <- ignore <$> getDirectoryTree (cfgOutDir cfg) @@ -54,13 +54,14 @@ checkFiles cfg@(Config { .. }) = do 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 + if (null failed && not somethingCrashed) + then do + putStrLn "All tests passed!" + exitSuccess + else do + unless (null failed) $ maybeDiff cfg failed + when somethingCrashed $ putStrLn "Some tests crashed." + exitFailure where ignore = filter (not . dcfgCheckIgnore cfgDirConfig) @@ -72,12 +73,14 @@ maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do forM_ files $ diffFile cfg diff -runHaddock :: Config c -> IO () +-- | Runs Haddock on all of the test packages, and returns whether 'True' if +-- any of them caused Haddock to crash. +runHaddock :: Config c -> IO Bool runHaddock cfg@(Config { .. }) = do createEmptyDirectory $ cfgOutDir cfg putStrLn "Generating documentation..." - forM_ cfgPackages $ \tpkg -> do + successes <- forM cfgPackages $ \tpkg -> do haddockStdOut <- openFile cfgHaddockStdOut WriteMode let pc = processConfig { pcArgs = concat @@ -87,9 +90,20 @@ runHaddock cfg@(Config { .. }) = do ] , pcEnv = Just $ cfgEnv , pcStdOut = Just $ haddockStdOut + , pcStdErr = Just $ haddockStdOut } - handle <- runProcess' cfgHaddockPath pc - waitForSuccess "Failed to run Haddock on specified test files" handle + + let msg = "Failed to run Haddock on test package '" ++ tpkgName tpkg ++ "'" + succeeded <- waitForSuccess msg stdout =<< runProcess' cfgHaddockPath pc + unless succeeded $ removeDirectoryRecursive (outDir cfgDirConfig tpkg) + + pure succeeded + + let somethingFailed = any not successes + when somethingFailed $ + putStrLn ("Haddock output is at '" ++ cfgHaddockStdOut ++ "'. " ++ + "This file can be set with `--haddock-stdout`.") + pure somethingFailed checkFile :: Config c -> FilePath -> IO CheckResult diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index 51032a3a..6447361f 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -196,6 +196,7 @@ loadConfig ccfg dcfg flags files = do cfgHaddockArgs <- liftM concat . sequence $ [ pure ["--no-warnings"] + , pure ["--bypass-interface-version-check"] , pure ["--odir=" ++ dcfgOutDir dcfg] , pure ["--optghc=-w"] , pure ["--optghc=-hide-all-packages"] @@ -223,13 +224,13 @@ printVersions env haddockPath = do { pcEnv = Just env , pcArgs = ["--version"] } - waitForSuccess "Failed to run `haddock --version`" handleHaddock + void $ waitForSuccess "Failed to run `haddock --version`" stderr handleHaddock handleGhc <- runProcess' haddockPath $ processConfig { pcEnv = Just env , pcArgs = ["--ghc-version"] } - waitForSuccess "Failed to run `haddock --ghc-version`" handleGhc + void $ waitForSuccess "Failed to run `haddock --ghc-version`" stderr handleGhc baseDependencies :: FilePath -> IO [String] diff --git a/haddock-test/src/Test/Haddock/Process.hs b/haddock-test/src/Test/Haddock/Process.hs index 52bf9533..a6cab9ac 100644 --- a/haddock-test/src/Test/Haddock/Process.hs +++ b/haddock-test/src/Test/Haddock/Process.hs @@ -40,10 +40,10 @@ 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 +-- | Wait for a process to finish running. If it ends up failing, print out the +-- error message. +waitForSuccess :: String -> Handle -> ProcessHandle -> IO Bool +waitForSuccess msg out handle = do + succeeded <- fmap (== ExitSuccess) $ waitForProcess handle + unless succeeded $ hPutStrLn out msg + pure succeeded diff --git a/haddock.cabal b/haddock.cabal index 1c84562d..39d01c4d 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -78,7 +78,7 @@ executable haddock xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, ghc-boot, - ghc == 8.6.*, + ghc == 8.7.*, bytestring, parsec, text, diff --git a/html-test/ref/TypeFamilies3.html b/html-test/ref/TypeFamilies3.html new file mode 100644 index 00000000..2dadf435 --- /dev/null +++ b/html-test/ref/TypeFamilies3.html @@ -0,0 +1,356 @@ +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >TypeFamilies3</title + ><link href="#" rel="stylesheet" type="text/css" title="Ocean" + /><link rel="stylesheet" type="text/css" href="#" + /><script src="haddock-bundle.min.js" async="async" type="text/javascript" + ></script + ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript" + ></script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="#" + >Contents</a + ></li + ><li + ><a href="#" + >Index</a + ></li + ></ul + ><p class="caption empty" + ></p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >Safe</td + ></tr + ></table + ><p class="caption" + >TypeFamilies3</p + ></div + ><div id="synopsis" + ><details id="syn" + ><summary + >Synopsis</summary + ><ul class="details-toggle" data-details-id="syn" + ><li class="src short" + ><span class="keyword" + >type family</span + > <a href="#" + >Foo</a + > a <span class="keyword" + >where ...</span + ></li + ><li class="src short" + ><span class="keyword" + >type family</span + > <a href="#" + >Bar</a + > a</li + ><li class="src short" + ><span class="keyword" + >data family</span + > <a href="#" + >Baz</a + > a</li + ></ul + ></details + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >type family</span + > <a id="t:Foo" class="def" + >Foo</a + > a <span class="keyword" + >where ...</span + > <a href="#" class="selflink" + >#</a + ></p + ><div class="doc" + ><p + >A closed type family</p + ></div + ><div class="subs equations" + ><p class="caption" + >Equations</p + ><table + ><tr + ><td class="src" + ><a href="#" title="TypeFamilies3" + >Foo</a + > () = <a href="#" title="Data.Int" + >Int</a + ></td + ><td class="doc empty" + ></td + ></tr + ><tr + ><td class="src" + ><a href="#" title="TypeFamilies3" + >Foo</a + > _ = ()</td + ><td class="doc empty" + ></td + ></tr + ></table + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >type family</span + > <a id="t:Bar" class="def" + >Bar</a + > a <a href="#" class="selflink" + >#</a + ></p + ><div class="doc" + ><p + >An open family</p + ></div + ><div class="subs instances" + ><details id="i:Bar" open="open" + ><summary + >Instances</summary + ><table + ><tr + ><td class="src clearfix" + ><span class="inst-left" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:Bar:Bar:1" + ></span + > <span class="keyword" + >type</span + > <a href="#" title="TypeFamilies3" + >Bar</a + > <a href="#" title="Data.Int" + >Int</a + ></span + > <a href="#" class="selflink" + >#</a + ></td + ><td class="doc empty" + ></td + ></tr + ><tr + ><td colspan="2" + ><details id="i:if:Bar:Bar:1" + ><summary class="hide-when-js-enabled" + >Instance details</summary + ><p + >Defined in <a href="#" + >TypeFamilies3</a + ></p + > <div class="src" + ><span class="keyword" + >type</span + > <a href="#" title="TypeFamilies3" + >Bar</a + > <a href="#" title="Data.Int" + >Int</a + > = ()</div + ></details + ></td + ></tr + ><tr + ><td class="src clearfix" + ><span class="inst-left" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:Bar:Bar:2" + ></span + > <span class="keyword" + >type</span + > <a href="#" title="TypeFamilies3" + >Bar</a + > ()</span + > <a href="#" class="selflink" + >#</a + ></td + ><td class="doc empty" + ></td + ></tr + ><tr + ><td colspan="2" + ><details id="i:if:Bar:Bar:2" + ><summary class="hide-when-js-enabled" + >Instance details</summary + ><p + >Defined in <a href="#" + >TypeFamilies3</a + ></p + > <div class="src" + ><span class="keyword" + >type</span + > <a href="#" title="TypeFamilies3" + >Bar</a + > () = <a href="#" title="Data.Int" + >Int</a + ></div + ></details + ></td + ></tr + ></table + ></details + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data family</span + > <a id="t:Baz" class="def" + >Baz</a + > a <a href="#" class="selflink" + >#</a + ></p + ><div class="doc" + ><p + >A data family</p + ></div + ><div class="subs instances" + ><details id="i:Baz" open="open" + ><summary + >Instances</summary + ><table + ><tr + ><td class="src clearfix" + ><span class="inst-left" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:Baz:Baz:1" + ></span + > <span class="keyword" + >newtype</span + > <a href="#" title="TypeFamilies3" + >Baz</a + > <a href="#" title="Prelude" + >Double</a + ></span + > <a href="#" class="selflink" + >#</a + ></td + ><td class="doc empty" + ></td + ></tr + ><tr + ><td colspan="2" + ><details id="i:if:Baz:Baz:1" + ><summary class="hide-when-js-enabled" + >Instance details</summary + ><p + >Defined in <a href="#" + >TypeFamilies3</a + ></p + > <div class="src" + ><span class="keyword" + >newtype</span + > <a href="#" title="TypeFamilies3" + >Baz</a + > <a href="#" title="Prelude" + >Double</a + > = <a id="v:Baz3" class="def" + >Baz3</a + > <a href="#" title="Prelude" + >Float</a + ></div + ></details + ></td + ></tr + ><tr + ><td class="src clearfix" + ><span class="inst-left" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:Baz:Baz:2" + ></span + > <span class="keyword" + >data</span + > <a href="#" title="TypeFamilies3" + >Baz</a + > <a href="#" title="Data.Int" + >Int</a + ></span + > <a href="#" class="selflink" + >#</a + ></td + ><td class="doc empty" + ></td + ></tr + ><tr + ><td colspan="2" + ><details id="i:if:Baz:Baz:2" + ><summary class="hide-when-js-enabled" + >Instance details</summary + ><p + >Defined in <a href="#" + >TypeFamilies3</a + ></p + > <div class="src" + ><span class="keyword" + >data</span + > <a href="#" title="TypeFamilies3" + >Baz</a + > <a href="#" title="Data.Int" + >Int</a + > = <a id="v:Baz2" class="def" + >Baz2</a + > <a href="#" title="Data.Bool" + >Bool</a + ></div + ></details + ></td + ></tr + ><tr + ><td class="src clearfix" + ><span class="inst-left" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:Baz:Baz:3" + ></span + > <span class="keyword" + >data</span + > <a href="#" title="TypeFamilies3" + >Baz</a + > ()</span + > <a href="#" class="selflink" + >#</a + ></td + ><td class="doc empty" + ></td + ></tr + ><tr + ><td colspan="2" + ><details id="i:if:Baz:Baz:3" + ><summary class="hide-when-js-enabled" + >Instance details</summary + ><p + >Defined in <a href="#" + >TypeFamilies3</a + ></p + > <div class="src" + ><span class="keyword" + >data</span + > <a href="#" title="TypeFamilies3" + >Baz</a + > () = <a id="v:Baz1" class="def" + >Baz1</a + ></div + ></details + ></td + ></tr + ></table + ></details + ></div + ></div + ></div + ></div + ><div id="footer" + ></div + ></body + ></html +>
\ No newline at end of file diff --git a/html-test/ref/UnboxedStuff.html b/html-test/ref/UnboxedStuff.html new file mode 100644 index 00000000..4c1196b9 --- /dev/null +++ b/html-test/ref/UnboxedStuff.html @@ -0,0 +1,196 @@ +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >UnboxedStuff</title + ><link href="#" rel="stylesheet" type="text/css" title="Ocean" + /><link rel="stylesheet" type="text/css" href="#" + /><script src="haddock-bundle.min.js" async="async" type="text/javascript" + ></script + ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript" + ></script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="#" + >Contents</a + ></li + ><li + ><a href="#" + >Index</a + ></li + ></ul + ><p class="caption empty" + ></p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >Safe</td + ></tr + ></table + ><p class="caption" + >UnboxedStuff</p + ></div + ><div id="table-of-contents" + ><p class="caption" + >Contents</p + ><ul + ><li + ><a href="#" + >Unboxed type constructors</a + ></li + ></ul + ></div + ><div id="synopsis" + ><details id="syn" + ><summary + >Synopsis</summary + ><ul class="details-toggle" data-details-id="syn" + ><li class="src short" + ><span class="keyword" + >data</span + > <a href="#" + >X</a + ></li + ><li class="src short" + ><span class="keyword" + >data</span + > <a href="#" + >Y</a + ></li + ><li class="src short" + ><span class="keyword" + >data</span + > <a href="#" + >Z</a + ></li + ><li class="src short" + ><a href="#" + >unboxedUnit</a + > :: (# #) -> (# #)</li + ><li class="src short" + ><a href="#" + >unboxedTuple</a + > :: (# <a href="#" title="UnboxedStuff" + >X</a + >, <a href="#" title="UnboxedStuff" + >Y</a + > #) -> (# <a href="#" title="UnboxedStuff" + >X</a + >, <a href="#" title="UnboxedStuff" + >Y</a + >, <a href="#" title="UnboxedStuff" + >Z</a + > #)</li + ><li class="src short" + ><a href="#" + >unboxedSum</a + > :: (# <a href="#" title="UnboxedStuff" + >X</a + > | <a href="#" title="UnboxedStuff" + >Y</a + > #) -> (# <a href="#" title="UnboxedStuff" + >X</a + > | <a href="#" title="UnboxedStuff" + >Y</a + > | <a href="#" title="UnboxedStuff" + >Z</a + > #)</li + ></ul + ></details + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a id="t:X" class="def" + >X</a + > <a href="#" class="selflink" + >#</a + ></p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a id="t:Y" class="def" + >Y</a + > <a href="#" class="selflink" + >#</a + ></p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a id="t:Z" class="def" + >Z</a + > <a href="#" class="selflink" + >#</a + ></p + ></div + ><a href="#" id="g:1" + ><h1 + >Unboxed type constructors</h1 + ></a + ><div class="top" + ><p class="src" + ><a id="v:unboxedUnit" class="def" + >unboxedUnit</a + > :: (# #) -> (# #) <a href="#" class="selflink" + >#</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a id="v:unboxedTuple" class="def" + >unboxedTuple</a + > :: (# <a href="#" title="UnboxedStuff" + >X</a + >, <a href="#" title="UnboxedStuff" + >Y</a + > #) -> (# <a href="#" title="UnboxedStuff" + >X</a + >, <a href="#" title="UnboxedStuff" + >Y</a + >, <a href="#" title="UnboxedStuff" + >Z</a + > #) <a href="#" class="selflink" + >#</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a id="v:unboxedSum" class="def" + >unboxedSum</a + > :: (# <a href="#" title="UnboxedStuff" + >X</a + > | <a href="#" title="UnboxedStuff" + >Y</a + > #) -> (# <a href="#" title="UnboxedStuff" + >X</a + > | <a href="#" title="UnboxedStuff" + >Y</a + > | <a href="#" title="UnboxedStuff" + >Z</a + > #) <a href="#" class="selflink" + >#</a + ></p + ></div + ></div + ></div + ><div id="footer" + ></div + ></body + ></html +>
\ No newline at end of file diff --git a/html-test/src/TypeFamilies3.hs b/html-test/src/TypeFamilies3.hs new file mode 100644 index 00000000..bde05fb8 --- /dev/null +++ b/html-test/src/TypeFamilies3.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TypeFamilies #-} + +module TypeFamilies3 where + +-- | A closed type family +type family Foo a where + Foo () = Int + Foo _ = () + +-- | An open family +type family Bar a + +type instance Bar Int = () +type instance Bar () = Int + +-- | A data family +data family Baz a + +data instance Baz () = Baz1 +data instance Baz Int = Baz2 Bool +newtype instance Baz Double = Baz3 Float diff --git a/html-test/src/UnboxedStuff.hs b/html-test/src/UnboxedStuff.hs new file mode 100644 index 00000000..bd1b1302 --- /dev/null +++ b/html-test/src/UnboxedStuff.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE UnboxedSums, UnboxedTuples #-} +module UnboxedStuff where + +data X +data Y +data Z + +-- * Unboxed type constructors + +unboxedUnit :: (# #) -> (# #) +unboxedUnit = undefined + +unboxedTuple :: (# X, Y #) -> (# X, Y, Z #) +unboxedTuple = undefined + +unboxedSum :: (# X | Y #) -> (# X | Y | Z #) +unboxedSum = undefined + diff --git a/latex-test/ref/TypeFamilies3/TypeFamilies3.tex b/latex-test/ref/TypeFamilies3/TypeFamilies3.tex new file mode 100644 index 00000000..2a8ad297 --- /dev/null +++ b/latex-test/ref/TypeFamilies3/TypeFamilies3.tex @@ -0,0 +1,44 @@ +\haddockmoduleheading{TypeFamilies3} +\label{module:TypeFamilies3} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module TypeFamilies3 ( + Foo, Bar, Baz(Baz3, Baz2, Baz1) + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +type\ family\ Foo\ a\ where +\end{tabular}]\haddockbegindoc +\haddockbeginargs +\haddockdecltt{Foo () = Int} \\ +\haddockdecltt{Foo \_ = ()} \\ +\end{tabulary}\par +A closed type family\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +type\ family\ Bar\ a +\end{tabular}]\haddockbegindoc +An open family\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +type\ instance\ Bar\ Int\ =\ ()\\type\ instance\ Bar\ ()\ =\ Int +\end{tabular}] +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ family\ Baz\ a +\end{tabular}]\haddockbegindoc +A data family\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +newtype\ instance\ Baz\ Double\\data\ instance\ Baz\ Int\\data\ instance\ Baz\ () +\end{tabular}] +\end{haddockdesc}
\ No newline at end of file diff --git a/latex-test/ref/TypeFamilies3/haddock.sty b/latex-test/ref/TypeFamilies3/haddock.sty new file mode 100644 index 00000000..6e031a98 --- /dev/null +++ b/latex-test/ref/TypeFamilies3/haddock.sty @@ -0,0 +1,57 @@ +% Default Haddock style definitions. To use your own style, invoke +% Haddock with the option --latex-style=mystyle. + +\usepackage{tabulary} % see below + +% make hyperlinks in the PDF, and add an expandabale index +\usepackage[pdftex,bookmarks=true]{hyperref} + +\newenvironment{haddocktitle} + {\begin{center}\bgroup\large\bfseries} + {\egroup\end{center}} +\newenvironment{haddockprologue}{\vspace{1in}}{} + +\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} + +\newcommand{\haddockbeginheader}{\hrulefill} +\newcommand{\haddockendheader}{\noindent\hrulefill} + +% a little gap before the ``Methods'' header +\newcommand{\haddockpremethods}{\vspace{2ex}} + +% inserted before \\begin{verbatim} +\newcommand{\haddockverb}{\small} + +% an identifier: add an index entry +\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} + +% The tabulary environment lets us have a column that takes up ``the +% rest of the space''. Unfortunately it doesn't allow +% the \end{tabulary} to be in the expansion of a macro, it must appear +% literally in the document text, so Haddock inserts +% the \end{tabulary} itself. +\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} +\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} + +\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} +\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} + +\makeatletter +\newenvironment{haddockdesc} + {\list{}{\labelwidth\z@ \itemindent-\leftmargin + \let\makelabel\haddocklabel}} + {\endlist} +\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} +\makeatother + +% after a declaration, start a new line for the documentation. +% Otherwise, the documentation starts right after the declaration, +% because we're using the list environment and the declaration is the +% ``label''. I tried making this newline part of the label, but +% couldn't get that to work reliably (the space seemed to stretch +% sometimes). +\newcommand{\haddockbegindoc}{\hfill\\[1ex]} + +% spacing between paragraphs and no \parindent looks better +\parskip=10pt plus2pt minus2pt +\setlength{\parindent}{0cm} diff --git a/latex-test/ref/TypeFamilies3/main.tex b/latex-test/ref/TypeFamilies3/main.tex new file mode 100644 index 00000000..2c98043c --- /dev/null +++ b/latex-test/ref/TypeFamilies3/main.tex @@ -0,0 +1,11 @@ +\documentclass{book} +\usepackage{haddock} +\begin{document} +\begin{titlepage} +\begin{haddocktitle} + +\end{haddocktitle} +\end{titlepage} +\tableofcontents +\input{TypeFamilies3} +\end{document}
\ No newline at end of file diff --git a/latex-test/ref/UnboxedStuff/UnboxedStuff.tex b/latex-test/ref/UnboxedStuff/UnboxedStuff.tex new file mode 100644 index 00000000..36d5c12b --- /dev/null +++ b/latex-test/ref/UnboxedStuff/UnboxedStuff.tex @@ -0,0 +1,36 @@ +\haddockmoduleheading{UnboxedStuff} +\label{module:UnboxedStuff} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module UnboxedStuff ( + X, Y, Z, unboxedUnit, unboxedTuple, unboxedSum + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ X +\end{tabular}] +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ Y +\end{tabular}] +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ Z +\end{tabular}] +\end{haddockdesc} +\section{Unboxed type constructors} +\begin{haddockdesc} +\item[ +unboxedUnit\ ::\ ({\char '43}\ {\char '43})\ ->\ ({\char '43}\ {\char '43}) +] +\item[ +unboxedTuple\ ::\ ({\char '43}\ X,\ Y\ {\char '43})\ ->\ ({\char '43}\ X,\ Y,\ Z\ {\char '43}) +] +\item[ +unboxedSum\ ::\ ({\char '43}\ X\ |\ Y\ {\char '43})\ ->\ ({\char '43}\ X\ |\ Y\ |\ Z\ {\char '43}) +] +\end{haddockdesc}
\ No newline at end of file diff --git a/latex-test/ref/UnboxedStuff/haddock.sty b/latex-test/ref/UnboxedStuff/haddock.sty new file mode 100644 index 00000000..6e031a98 --- /dev/null +++ b/latex-test/ref/UnboxedStuff/haddock.sty @@ -0,0 +1,57 @@ +% Default Haddock style definitions. To use your own style, invoke +% Haddock with the option --latex-style=mystyle. + +\usepackage{tabulary} % see below + +% make hyperlinks in the PDF, and add an expandabale index +\usepackage[pdftex,bookmarks=true]{hyperref} + +\newenvironment{haddocktitle} + {\begin{center}\bgroup\large\bfseries} + {\egroup\end{center}} +\newenvironment{haddockprologue}{\vspace{1in}}{} + +\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} + +\newcommand{\haddockbeginheader}{\hrulefill} +\newcommand{\haddockendheader}{\noindent\hrulefill} + +% a little gap before the ``Methods'' header +\newcommand{\haddockpremethods}{\vspace{2ex}} + +% inserted before \\begin{verbatim} +\newcommand{\haddockverb}{\small} + +% an identifier: add an index entry +\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} + +% The tabulary environment lets us have a column that takes up ``the +% rest of the space''. Unfortunately it doesn't allow +% the \end{tabulary} to be in the expansion of a macro, it must appear +% literally in the document text, so Haddock inserts +% the \end{tabulary} itself. +\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} +\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} + +\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} +\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} + +\makeatletter +\newenvironment{haddockdesc} + {\list{}{\labelwidth\z@ \itemindent-\leftmargin + \let\makelabel\haddocklabel}} + {\endlist} +\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} +\makeatother + +% after a declaration, start a new line for the documentation. +% Otherwise, the documentation starts right after the declaration, +% because we're using the list environment and the declaration is the +% ``label''. I tried making this newline part of the label, but +% couldn't get that to work reliably (the space seemed to stretch +% sometimes). +\newcommand{\haddockbegindoc}{\hfill\\[1ex]} + +% spacing between paragraphs and no \parindent looks better +\parskip=10pt plus2pt minus2pt +\setlength{\parindent}{0cm} diff --git a/latex-test/ref/UnboxedStuff/main.tex b/latex-test/ref/UnboxedStuff/main.tex new file mode 100644 index 00000000..e34c5f14 --- /dev/null +++ b/latex-test/ref/UnboxedStuff/main.tex @@ -0,0 +1,11 @@ +\documentclass{book} +\usepackage{haddock} +\begin{document} +\begin{titlepage} +\begin{haddocktitle} + +\end{haddocktitle} +\end{titlepage} +\tableofcontents +\input{UnboxedStuff} +\end{document}
\ No newline at end of file diff --git a/latex-test/src/TypeFamilies3/TypeFamilies3.hs b/latex-test/src/TypeFamilies3/TypeFamilies3.hs new file mode 100644 index 00000000..bde05fb8 --- /dev/null +++ b/latex-test/src/TypeFamilies3/TypeFamilies3.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TypeFamilies #-} + +module TypeFamilies3 where + +-- | A closed type family +type family Foo a where + Foo () = Int + Foo _ = () + +-- | An open family +type family Bar a + +type instance Bar Int = () +type instance Bar () = Int + +-- | A data family +data family Baz a + +data instance Baz () = Baz1 +data instance Baz Int = Baz2 Bool +newtype instance Baz Double = Baz3 Float diff --git a/latex-test/src/UnboxedStuff/UnboxedStuff.hs b/latex-test/src/UnboxedStuff/UnboxedStuff.hs new file mode 100644 index 00000000..bd1b1302 --- /dev/null +++ b/latex-test/src/UnboxedStuff/UnboxedStuff.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE UnboxedSums, UnboxedTuples #-} +module UnboxedStuff where + +data X +data Y +data Z + +-- * Unboxed type constructors + +unboxedUnit :: (# #) -> (# #) +unboxedUnit = undefined + +unboxedTuple :: (# X, Y #) -> (# X, Y, Z #) +unboxedTuple = undefined + +unboxedSum :: (# X | Y #) -> (# X | Y | Z #) +unboxedSum = undefined + |