diff options
31 files changed, 745 insertions, 571 deletions
diff --git a/.travis.yml b/.travis.yml index 2bcb301a..2417dea9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,3 +1,6 @@ +# NOTE: manually changes were made to an otherwise autogenerated script. This is to +# query GHC CI artifacts instead of going via Herbert's PPA +# # This Travis job script has been generated by a script via # # make_travis_yml_2.hs 'haddock.cabal' @@ -28,46 +31,50 @@ before_cache: matrix: include: - - compiler: "ghc-head" - env: GHCHEAD=true - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}} + - os: linux + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head], sources: [hvr-ghc]}} + env: + - GHC_ZIP='https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/download?job=validate-x86_64-linux-deb8' before_install: - - HC=${CC} + # Manually install GHC validate artifact + - travis_retry curl -L $GHC_ZIP --output artifact.zip + - unzip artifact.zip + - tar xpf ghc.tar.xz --strip-components 1 + - ./configure + - sudo make V=1 install + + # Set up some vars + - HC=ghc - HCPKG=${HC/ghc/ghc-pkg} - - unset CC - - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH + - PATH=/usr/local/bin:/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} - - GHCHEAD=${GHCHEAD-false} + - BENCH=--enable-benchmarks + - TEST=--enable-tests - 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 + 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 + 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*$' + grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - cabal new-update head.hackage -v - fi + cabal new-update head.hackage -v - 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 @@ -76,8 +83,8 @@ install: script: - if [ -f configure.ac ]; then autoreconf -i; fi - rm -rf dist/ - - cabal sdist # test that a source-distribution can be generated - - cd dist/ + - cabal new-sdist # test that a source-distribution can be generated + - cd dist-newstyle/sdist/ - SRCTAR=(${PKGNAME}-*.tar.gz) - SRC_BASENAME="${SRCTAR/%.tar.gz}" - tar -xvf "./$SRC_BASENAME.tar.gz" diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index d996a6ce..f3cd93a3 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -46,7 +46,7 @@ library , Cabal ^>= 2.4.0 , ghc ^>= 8.7 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.7.0 + , haddock-library ^>= 1.8.0 , xhtml ^>= 3000.2.2 -- Versions for the dependencies below are transitively pinned by @@ -170,7 +170,7 @@ test-suite spec build-depends: Cabal ^>= 2.4 , ghc ^>= 8.7 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.7.0 + , haddock-library ^>= 1.8.0 , xhtml ^>= 3000.2.2 , hspec >= 2.4.4 && < 2.6 , QuickCheck ^>= 2.11 diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 16ec582e..9e3186e5 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -263,8 +263,13 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - resType = apps $ map (reL . HsTyVar NoExt NotPromoted . reL) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat] + tyVarArg (UserTyVar _ n) = HsTyVar NoExt NotPromoted n + tyVarArg (KindedTyVar _ n lty) = HsKindSig NoExt (reL (HsTyVar NoExt NotPromoted n)) lty + tyVarArg _ = panic "ppCtor" + + resType = apps $ map reL $ + (HsTyVar NoExt NotPromoted (reL (tcdName dat))) : + map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 12256a00..d0752506 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -960,7 +960,7 @@ ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode pp_hs_context :: [HsType DocNameI] -> Bool -> LaTeX pp_hs_context [] _ = empty -pp_hs_context [p] unicode = ppType unicode p +pp_hs_context [p] unicode = ppCtxType unicode p pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) @@ -995,11 +995,11 @@ ppLType unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y) ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) - -ppType, ppParendType, ppFunLhType :: Bool -> HsType DocNameI -> LaTeX +ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX 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 +ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty @@ -1045,7 +1045,7 @@ ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys) ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys) ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind) ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) -ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty ty u) +ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u ppr_mono_ty (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty (HsRecTy {}) _ = text "{..}" ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy" @@ -1110,7 +1110,7 @@ ppVerbOccName :: OccName -> LaTeX ppVerbOccName = text . latexFilter . occNameString ppIPName :: HsIPName -> LaTeX -ppIPName ip = text $ unpackFS $ hsIPNameFS ip +ppIPName = text . ('?':) . unpackFS . hsIPNameFS ppOccName :: OccName -> LaTeX ppOccName = text . occNameString diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 5312bfc7..9c876b14 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -12,20 +12,22 @@ -- Conversion between TyThing and HsDecl. This functionality may be moved into -- GHC at some point. ----------------------------------------------------------------------------- -module Haddock.Convert where --- Some other functions turned out to be useful for converting --- instance heads, which aren't TyThings, so just export everything. +module Haddock.Convert ( + tyThingToLHsDecl, + synifyInstHead, + synifyFamInst, + PrintRuntimeReps(..), +) where import Bag ( emptyBag ) import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..) - , PromotionFlag(..) ) + , PromotionFlag(..), DefMethSpec(..) ) import Class import CoAxiom import ConLike import Data.Either (lefts, rights) import DataCon import FamInstEnv -import FV import HsSyn import Name import NameSet ( emptyNameSet ) @@ -42,19 +44,28 @@ import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey , liftedRepDataConKey ) import Unique ( getUnique ) -import Util ( chkAppend, compareLength, dropList, filterByList, filterOut - , splitAtList ) +import Util ( chkAppend,dropList, filterByList, filterOut, splitAtList ) import Var import VarSet import Haddock.Types import Haddock.Interface.Specialize +import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars ) +import Data.Maybe ( catMaybes, maybeToList ) +-- | Whether or not to default 'RuntimeRep' variables to 'LiftedRep'. Check +-- out Note [Defaulting RuntimeRep variables] in IfaceType.hs for the +-- motivation. +data PrintRuntimeReps = ShowRuntimeRep | HideRuntimeRep deriving Show + -- the main function here! yay! -tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl GhcRn)) -tyThingToLHsDecl t = case t of +tyThingToLHsDecl + :: PrintRuntimeReps + -> TyThing + -> Either ErrMsg ([ErrMsg], (HsDecl GhcRn)) +tyThingToLHsDecl prr t = case t of -- ids (functions and zero-argument a.k.a. CAFs) get a type signature. -- Including built-in functions like seq. -- foreign-imported functions could be represented with ForD @@ -63,40 +74,60 @@ tyThingToLHsDecl t = case t of -- in a future code version we could turn idVarDetails = foreign-call -- into a ForD instead of a SigD if we wanted. Haddock doesn't -- need to care. - AnId i -> allOK $ SigD noExt (synifyIdSig ImplicitizeForAll i) + AnId i -> allOK $ SigD noExt (synifyIdSig prr ImplicitizeForAll [] i) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) ATyCon tc | Just cl <- tyConClass_maybe tc -- classes are just a little tedious - -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a) - extractFamilyDecl (FamDecl _ d) = return $ noLoc d + -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (FamilyDecl a) + extractFamilyDecl (FamDecl _ d) = return d extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" - atTyClDecls = [synifyTyCon Nothing at_tc | ATI at_tc _ <- classATItems cl] - atFamDecls = map extractFamilyDecl (rights atTyClDecls) - tyClErrors = lefts atTyClDecls - famDeclErrors = lefts atFamDecls - in withErrs (tyClErrors ++ famDeclErrors) . TyClD noExt $ ClassDecl + extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltEqn GhcRn + extractFamDefDecl fd rhs = FamEqn + { feqn_ext = noExt + , feqn_tycon = fdLName fd + , feqn_bndrs = Nothing + -- TODO: this must change eventually + , feqn_pats = fdTyVars fd + , feqn_fixity = fdFixity fd + , feqn_rhs = synifyType WithinType [] rhs } + + extractAtItem + :: ClassATItem + -> Either ErrMsg (LFamilyDecl GhcRn, Maybe (LTyFamDefltEqn GhcRn)) + extractAtItem (ATI at_tc def) = do + tyDecl <- synifyTyCon prr Nothing at_tc + famDecl <- extractFamilyDecl tyDecl + let defEqnTy = fmap (noLoc . extractFamDefDecl famDecl . fst) def + pure (noLoc famDecl, defEqnTy) + + atTyClDecls = map extractAtItem (classATItems cl) + (atFamDecls, atDefFamDecls) = unzip (rights atTyClDecls) + vs = tyConVisibleTyVars (classTyCon cl) + + in withErrs (lefts atTyClDecls) . TyClD noExt $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl - , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl)) - , tcdFixity = Prefix + , tcdTyVars = synifyTyVars vs + , tcdFixity = synifyFixity cl , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl , tcdSigs = noLoc (MinimalSig noExt NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : - map (noLoc . synifyTcIdSig DeleteTopLevelQuantification) - (classMethods cl) + [ noLoc tcdSig + | clsOp <- classOpItems cl + , tcdSig <- synifyTcIdSig vs clsOp ] , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature -- class associated-types are a subset of TyCon: - , tcdATs = rights atFamDecls - , tcdATDefs = [] --ignore associated type defaults + , tcdATs = atFamDecls + , tcdATDefs = catMaybes atDefFamDecls , tcdDocs = [] --we don't have any docs at this point , tcdCExt = placeHolderNamesTc } | otherwise - -> synifyTyCon Nothing tc >>= allOK . TyClD noExt + -> synifyTyCon prr Nothing tc >>= allOK . TyClD noExt -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) @@ -104,7 +135,7 @@ tyThingToLHsDecl t = case t of -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD noExt (TypeSig noExt [synifyName dc] - (synifySigWcType ImplicitizeForAll (dataConUserType dc))) + (synifySigWcType ImplicitizeForAll [] (dataConUserType dc))) AConLike (PatSynCon ps) -> allOK . SigD noExt $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps) @@ -116,17 +147,17 @@ synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) = let name = synifyName tc args_types_only = filterOutInvisibleTypes tc args - typats = map (synifyType WithinType) args_types_only + typats = map (synifyType WithinType []) args_types_only annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) args_types_only typats - hs_rhs = synifyType WithinType rhs + hs_rhs = synifyType WithinType [] rhs in HsIB { hsib_ext = map tyVarName tkvs , hsib_body = FamEqn { feqn_ext = noExt , feqn_tycon = name , feqn_bndrs = Nothing - -- this must change eventually + -- TODO: this must change eventually , feqn_pats = map HsValArg annot_typats - , feqn_fixity = Prefix + , feqn_fixity = synifyFixity name , feqn_rhs = hs_rhs } } where fam_tvs = tyConVisibleTyVars tc @@ -141,42 +172,51 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error - = synifyTyCon (Just ax) tc >>= return . TyClD noExt + = synifyTyCon ShowRuntimeRep (Just ax) tc >>= return . TyClD noExt | otherwise = Left "synifyAxiom: closed/open family confusion" --- | Turn type constructors into type class declarations -synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl GhcRn) -synifyTyCon _coax tc +-- | Turn type constructors into data declarations, type families, or type synonyms +synifyTyCon + :: PrintRuntimeReps + -> Maybe (CoAxiom br) -- ^ RHS of type synonym + -> TyCon -- ^ type constructor to convert + -> Either ErrMsg (TyClDecl GhcRn) +synifyTyCon prr _coax tc | isFunTyCon tc || isPrimTyCon tc = return $ DataDecl { tcdLName = synifyName tc - , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: - let mk_hs_tv realKind fakeTyVar - = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar)) - (synifyKindSig realKind) - in HsQTvs { hsq_ext = + , tcdTyVars = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = [] -- No kind polymorphism , hsq_dependent = emptyNameSet } - , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) - alphaTyVars --a, b, c... which are unfortunately all kind * + , hsq_explicit = zipWith mk_hs_tv + tyVarKinds + alphaTyVars --a, b, c... which are unfortunately all kind * } - , tcdFixity = Prefix + , tcdFixity = synifyFixity tc , tcdDataDefn = HsDataDefn { dd_ext = noExt , dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = noLoc [] , dd_cType = Nothing - , dd_kindSig = Just (synifyKindSig (tyConKind tc)) + , dd_kindSig = synifyDataTyConReturnKind tc -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = noLoc [] } , tcdDExt = DataDeclRn False placeHolderNamesTc } + where + -- tyConTyVars doesn't work on fun/prim, but we can make them up: + mk_hs_tv realKind fakeTyVar + | isLiftedTypeKind realKind = noLoc $ UserTyVar noExt (noLoc (getName fakeTyVar)) + | otherwise = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar)) (synifyKindSig realKind) + + conKind = defaultType prr (tyConKind tc) + tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind -synifyTyCon _coax tc +synifyTyCon _prr _coax tc | Just flav <- famTyConFlav_maybe tc = case flav of -- Type families @@ -200,7 +240,7 @@ synifyTyCon _coax tc , fdInfo = i , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConVisibleTyVars tc) - , fdFixity = Prefix + , fdFixity = synifyFixity tc , fdResultSig = synifyFamilyResultSig resultVar (tyConResKind tc) , fdInjectivityAnn = @@ -208,13 +248,13 @@ synifyTyCon _coax tc (tyConInjectivityInfo tc) } -synifyTyCon coax tc +synifyTyCon _prr coax tc | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdSExt = emptyNameSet , tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc) - , tcdFixity = Prefix - , tcdRhs = synifyType WithinType ty } + , tcdFixity = synifyFixity tc + , tcdRhs = synifyType WithinType [] ty } | otherwise = -- (closed) newtype and data let @@ -242,7 +282,7 @@ synifyTyCon coax tc -- That seems like an acceptable compromise (they'll just be documented -- in prefix position), since, otherwise, the logic (at best) gets much more -- complicated. (would use dataConIsInfix.) - use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc) + use_gadt_syntax = isGadtSyntaxTyCon tc consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any. @@ -256,31 +296,31 @@ synifyTyCon coax tc , dd_derivs = alg_deriv } in case lefts consRaw of [] -> return $ - DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdFixity = Prefix + DataDecl { tcdLName = name, tcdTyVars = tyvars + , tcdFixity = synifyFixity name , tcdDataDefn = defn , tcdDExt = DataDeclRn False placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs --- In this module, every TyCon being considered has come from an interface +-- | In this module, every TyCon being considered has come from an interface -- file. This means that when considering a data type constructor such as: -- --- data Foo (w :: *) (m :: * -> *) (a :: *) +-- > data Foo (w :: *) (m :: * -> *) (a :: *) -- -- Then its tyConKind will be (* -> (* -> *) -> * -> *). But beware! We are -- also rendering the type variables of Foo, so if we synify the tyConKind of -- Foo in full, we will end up displaying this in Haddock: -- --- data Foo (w :: *) (m :: * -> *) (a :: *) --- :: * -> (* -> *) -> * -> * +-- > data Foo (w :: *) (m :: * -> *) (a :: *) +-- > :: * -> (* -> *) -> * -> * -- --- Which is entirely wrong (#548). We only want to display the *return* kind, +-- Which is entirely wrong (#548). We only want to display the /return/ kind, -- which this function obtains. synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind GhcRn) synifyDataTyConReturnKind tc - = case splitFunTys (tyConKind tc) of - (_, ret_kind) - | isLiftedTypeKind ret_kind -> Nothing -- Don't bother displaying :: * - | otherwise -> Just (synifyKindSig ret_kind) + | isLiftedTypeKind ret_kind = Nothing -- Don't bother displaying :: * + | otherwise = Just (synifyKindSig ret_kind) + where ret_kind = tyConResKind tc synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity -> Maybe (LInjectivityAnn GhcRn) @@ -291,8 +331,9 @@ synifyInjectivityAnn (Just lhs) tvs (Injective inj) = in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn -synifyFamilyResultSig Nothing kind = - noLoc $ KindSig noExt (synifyKindSig kind) +synifyFamilyResultSig Nothing kind + | isLiftedTypeKind kind = noLoc $ NoSig noExt + | otherwise = noLoc $ KindSig noExt (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = noLoc $ TyVarSig noExt (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind)) @@ -310,14 +351,16 @@ synifyDataCon use_gadt_syntax dc = use_named_field_syntax = not (null field_tys) name = synifyName dc -- con_qvars means a different thing depending on gadt-syntax - (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc + (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc + user_tvs = dataConUserTyVars dc -- Used for GADT data constructors -- skip any EqTheta, use 'orig'inal syntax - ctx = synifyCtx theta + ctx | null theta = Nothing + | otherwise = Just $ synifyCtx theta linear_tys = zipWith (\ty bang -> - let tySyn = synifyType WithinType ty + let tySyn = synifyType WithinType [] ty in case bang of (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn bang' -> noLoc $ HsBangTy noExt bang' tySyn) @@ -341,33 +384,55 @@ synifyDataCon use_gadt_syntax dc = then return $ noLoc $ ConDeclGADT { con_g_ext = noExt , con_names = [name] - , con_forall = noLoc True - , con_qvars = synifyTyVars (univ_tvs ++ ex_tvs) - , con_mb_cxt = Just ctx - , con_args = hat - , con_res_ty = synifyType WithinType res_ty - , con_doc = Nothing } + , con_forall = noLoc $ not $ null user_tvs + , con_qvars = synifyTyVars user_tvs + , con_mb_cxt = ctx + , con_args = hat + , con_res_ty = synifyType WithinType [] res_ty + , con_doc = Nothing } else return $ noLoc $ ConDeclH98 { con_ext = noExt , con_name = name - , con_forall = noLoc True + , con_forall = noLoc False , con_ex_tvs = map synifyTyVar ex_tvs - , con_mb_cxt = Just ctx + , con_mb_cxt = ctx , con_args = hat , con_doc = Nothing } synifyName :: NamedThing n => n -> Located Name synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) - -synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn -synifyIdSig s i = TypeSig noExt [synifyName i] (synifySigWcType s (varType i)) - -synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn -synifyTcIdSig s i = ClassOpSig noExt False [synifyName i] (synifySigType s (varType i)) +-- | Guess the fixity of a something with a name. This isn't quite right, since +-- a user can always declare an infix name in prefix form or a prefix name in +-- infix form. Unfortunately, that is not something we can usually reconstruct. +synifyFixity :: NamedThing n => n -> LexicalFixity +synifyFixity n | isSymOcc (getOccName n) = Infix + | otherwise = Prefix + +synifyIdSig + :: PrintRuntimeReps -- ^ are we printing tyvars of kind 'RuntimeRep'? + -> SynifyTypeState -- ^ what to do with a 'forall' + -> [TyVar] -- ^ free variables in the type to convert + -> Id -- ^ the 'Id' from which to get the type signature + -> Sig GhcRn +synifyIdSig prr s vs i = TypeSig noExt [synifyName i] (synifySigWcType s vs t) + where + t = defaultType prr (varType i) + +-- | Turn a 'ClassOpItem' into a list of signatures. The list returned is going +-- to contain the synified 'ClassOpSig' as well (when appropriate) a default +-- 'ClassOpSig'. +synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn] +synifyTcIdSig vs (i, dm) = + [ ClassOpSig noExt False [synifyName i] (mainSig (varType i)) ] ++ + [ ClassOpSig noExt True [noLoc dn] (defSig dt) + | Just (dn, GenericDM dt) <- [dm] ] + where + mainSig t = synifySigType DeleteTopLevelQuantification vs t + defSig t = synifySigType ImplicitizeForAll vs t synifyCtx :: [PredType] -> LHsContext GhcRn -synifyCtx = noLoc . map (synifyType WithinType) +synifyCtx = noLoc . map (synifyType WithinType []) synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn @@ -376,13 +441,20 @@ synifyTyVars ktvs = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = [] , hsq_explicit = map synifyTyVar ktvs } synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn -synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar noExt (noLoc name)) - | otherwise = noLoc (KindedTyVar noExt (noLoc name) (synifyKindSig kind)) +synifyTyVar = synifyTyVar' emptyVarSet + +-- | Like 'synifyTyVar', but accepts a set of variables for which to omit kind +-- signatures (even if they don't have the lifted type kind). +synifyTyVar' :: VarSet -> TyVar -> LHsTyVarBndr GhcRn +synifyTyVar' no_kinds tv + | isLiftedTypeKind kind || tv `elemVarSet` no_kinds + = noLoc (UserTyVar noExt (noLoc name)) + | otherwise = noLoc (KindedTyVar noExt (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv + -- | Annotate (with HsKingSig) a type if the first parameter is True -- and if the type contains a free variable. -- This is used to synify type patterns for poly-kinded tyvars in @@ -394,7 +466,7 @@ annotHsType _ _ hs_ty@(L _ (HsKindSig {})) = hs_ty annotHsType True ty hs_ty | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty = let ki = typeKind ty - hs_ki = synifyType WithinType ki + hs_ki = synifyType WithinType [] ki in noLoc (HsKindSig noExt hs_ty hs_ki) annotHsType _ _ hs_ty = hs_ty @@ -417,7 +489,8 @@ data SynifyTypeState -- quite understand what's going on. | ImplicitizeForAll -- ^ beginning of a function definition, in which, to make it look - -- less ugly, those rank-1 foralls are made implicit. + -- less ugly, those rank-1 foralls (without kind annotations) are made + -- implicit. | DeleteTopLevelQuantification -- ^ because in class methods the context is added to the type -- (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@) @@ -426,22 +499,33 @@ data SynifyTypeState -- the defining class gets to quantify all its functions for free! -synifySigType :: SynifyTypeState -> Type -> LHsSigType GhcRn +synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn -- The empty binders is a bit suspicious; -- what if the type has free variables? -synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty) +synifySigType s vs ty = mkEmptyImplicitBndrs (synifyType s vs ty) -synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType GhcRn +synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType) -synifySigWcType s ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s ty)) +synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s vs ty)) synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn -- Ditto (see synifySigType) synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) -synifyType :: SynifyTypeState -> Type -> LHsType GhcRn -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv) -synifyType _ (TyConApp tc tys) +-- | Depending on the first argument, try to default all type variables of kind +-- 'RuntimeRep' to 'LiftedType'. +defaultType :: PrintRuntimeReps -> Type -> Type +defaultType ShowRuntimeRep = id +defaultType HideRuntimeRep = defaultRuntimeRepVars + +-- | Convert a core type into an 'HsType'. +synifyType + :: SynifyTypeState -- ^ what to do with a 'forall' + -> [TyVar] -- ^ free variables in the type to convert + -> Type -- ^ the type to convert + -> LHsType GhcRn +synifyType _ _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv) +synifyType _ vs (TyConApp tc tys) = maybe_sig res_ty where res_ty :: LHsType GhcRn @@ -453,27 +537,27 @@ synifyType _ (TyConApp tc tys) = noLoc (HsTyVar noExt NotPromoted (noLoc liftedTypeKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc - , tyConArity tc == length tys + , tyConArity tc == tys_len = noLoc $ HsTupleTy noExt (case sort of BoxedTuple -> HsBoxedTuple ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) - (map (synifyType WithinType) vis_tys) - | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType) vis_tys) + (map (synifyType WithinType vs) vis_tys) + | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType vs) vis_tys) | Just dc <- isPromotedDataCon_maybe tc , isTupleDataCon dc , dataConSourceArity dc == length vis_tys - = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType) vis_tys) + = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType vs) vis_tys) -- ditto for lists | getName tc == listTyConName, [ty] <- vis_tys = - noLoc $ HsListTy noExt (synifyType WithinType ty) + noLoc $ HsListTy noExt (synifyType WithinType vs ty) | tc == promotedNilDataCon, [] <- vis_tys = noLoc $ HsExplicitListTy noExt IsPromoted [] | tc == promotedConsDataCon , [ty1, ty2] <- vis_tys - = let hTy = synifyType WithinType ty1 - in case synifyType WithinType ty2 of + = let hTy = synifyType WithinType vs ty1 + in case synifyType WithinType vs ty2 of tTy | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy -> noLoc $ HsExplicitListTy noExt IsPromoted (hTy : tTy') | otherwise @@ -482,21 +566,21 @@ synifyType _ (TyConApp tc tys) | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name - = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType ty) + = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType vs ty) -- and equalities | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys = noLoc $ HsOpTy noExt - (synifyType WithinType ty1) + (synifyType WithinType vs ty1) (noLoc eqTyConName) - (synifyType WithinType ty2) + (synifyType WithinType vs ty2) -- and infix type operators | isSymOcc (nameOccName (getName tc)) , ty1:ty2:tys_rest <- vis_tys = mk_app_tys (HsOpTy noExt - (synifyType WithinType ty1) + (synifyType WithinType vs ty1) (noLoc $ getName tc) - (synifyType WithinType ty2)) + (synifyType WithinType vs ty2)) tys_rest -- Most TyCons: | otherwise @@ -507,109 +591,188 @@ synifyType _ (TyConApp tc tys) mk_app_tys ty_app ty_args = foldl (\t1 t2 -> noLoc $ HsAppTy noExt t1 t2) (noLoc ty_app) - (map (synifyType WithinType) $ + (map (synifyType WithinType vs) $ filterOut isCoercionTy ty_args) - vis_tys = filterOutInvisibleTypes tc tys - binders = tyConBinders tc - res_kind = tyConResKind tc + tys_len = length tys + vis_tys = filterOutInvisibleTypes tc tys maybe_sig :: LHsType GhcRn -> LHsType GhcRn maybe_sig ty' - | needs_kind_sig + | tyConAppNeedsKindSig False tc tys_len = let full_kind = typeKind (mkTyConApp tc tys) - full_kind' = synifyType WithinType full_kind + full_kind' = synifyType WithinType vs full_kind in noLoc $ HsKindSig noExt ty' full_kind' | otherwise = ty' - needs_kind_sig :: Bool - needs_kind_sig - | GT <- compareLength tys binders - = False - | otherwise - = let (dropped_binders, remaining_binders) - = splitAtList tys binders - result_kind = mkTyConKind remaining_binders res_kind - result_vars = tyCoVarsOfType result_kind - dropped_vars = fvVarSet $ - mapUnionFV injectiveVarsOfBinder dropped_binders - - in not (subVarSet result_vars dropped_vars) - -synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 -synifyType _ (AppTy t1 t2) = let - s1 = synifyType WithinType t1 - s2 = synifyType WithinType t2 +synifyType s vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1 +synifyType _ vs (AppTy t1 t2) = let + s1 = synifyType WithinType vs t1 + s2 = synifyType WithinType vs t2 in noLoc $ HsAppTy noExt s1 s2 -synifyType _ (FunTy t1 t2) = let - s1 = synifyType WithinType t1 - s2 = synifyType WithinType t2 - in noLoc $ HsFunTy noExt s1 s2 -synifyType s forallty@(ForAllTy _tv _ty) = - let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms forallty +synifyType s vs funty@(FunTy t1 t2) + | isPredTy t1 = synifyForAllType s vs funty + | otherwise = let s1 = synifyType WithinType vs t1 + s2 = synifyType WithinType vs t2 + in noLoc $ HsFunTy noExt s1 s2 +synifyType s vs forallty@(ForAllTy _tv _ty) = synifyForAllType s vs forallty + +synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t +synifyType s vs (CastTy t _) = synifyType s vs t +synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion" + +-- | Process a 'Type' which starts with a forall or a constraint into +-- an 'HsType' +synifyForAllType + :: SynifyTypeState -- ^ what to do with the 'forall' + -> [TyVar] -- ^ free variables in the type to convert + -> Type -- ^ the forall type to convert + -> LHsType GhcRn +synifyForAllType s vs ty = + let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx - , hst_xqual = noExt - , hst_body = synifyType WithinType tau } + , hst_xqual = noExt + , hst_body = synifyType WithinType (tvs' ++ vs) tau } + + sTy = HsForAllTy { hst_bndrs = sTvs + , hst_xforall = noExt + , hst_body = noLoc sPhi } + + sTvs = map synifyTyVar tvs + + -- Figure out what the type variable order would be inferred in the + -- absence of an explicit forall + tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau]) + in case s of - DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau - WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs - , hst_xforall = noExt - , hst_body = noLoc sPhi } - ImplicitizeForAll -> noLoc sPhi + DeleteTopLevelQuantification -> synifyType ImplicitizeForAll (tvs' ++ vs) tau + + -- Put a forall in if there are any type variables + WithinType + | not (null tvs) -> noLoc sTy + | otherwise -> noLoc sPhi + + ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau + + +-- | Put a forall in if there are any type variables which require +-- explicit kind annotations or if the inferred type variable order +-- would be different. +implicitForAll + :: [TyCon] -- ^ type constructors that determine their args kinds + -> [TyVar] -- ^ free variables in the type to convert + -> [TyVar] -- ^ type variable binders in the forall + -> ThetaType -- ^ constraints right after the forall + -> ([TyVar] -> Type -> LHsType GhcRn) -- ^ how to convert the inner type + -> Type -- ^ inner type + -> LHsType GhcRn +implicitForAll tycons vs tvs ctx synInner tau + | any (isHsKindedTyVar . unLoc) sTvs = noLoc sTy + | tvs' /= tvs = noLoc sTy + | otherwise = noLoc sPhi + where + sRho = synInner (tvs' ++ vs) tau + sPhi | null ctx = unLoc sRho + | otherwise + = HsQualTy { hst_ctxt = synifyCtx ctx + , hst_xqual = noExt + , hst_body = synInner (tvs' ++ vs) tau } + sTy = HsForAllTy { hst_bndrs = sTvs + , hst_xforall = noExt + , hst_body = noLoc sPhi } + + no_kinds_needed = noKindTyVars tycons tau + sTvs = map (synifyTyVar' no_kinds_needed) tvs + + -- Figure out what the type variable order would be inferred in the + -- absence of an explicit forall + tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau]) -synifyType _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t -synifyType s (CastTy t _) = synifyType s t -synifyType _ (CoercionTy {}) = error "synifyType:Coercion" + + +-- | Find the set of type variables whose kind signatures can be properly +-- inferred just from their uses in the type signature. This means the type +-- variable to has at least one fully applied use @f x1 x2 ... xn@ where: +-- +-- * @f@ has a function kind where the arguments have the same kinds +-- as @x1 x2 ... xn@. +-- +-- * @f@ has a function kind whose final return has lifted type kind +-- +noKindTyVars + :: [TyCon] -- ^ type constructors that determine their args kinds + -> Type -- ^ type to inspect + -> VarSet -- ^ set of variables whose kinds can be inferred from uses in the type +noKindTyVars _ (TyVarTy var) + | isLiftedTypeKind (tyVarKind var) = unitVarSet var +noKindTyVars ts ty + | (f, xs) <- splitAppTys ty + , not (null xs) + = let args = map (noKindTyVars ts) xs + func = case f of + TyVarTy var | (xsKinds, outKind) <- splitFunTys (tyVarKind var) + , xsKinds `eqTypes` map typeKind xs + , isLiftedTypeKind outKind + -> unitVarSet var + TyConApp t ks | t `elem` ts + , all noFreeVarsOfType ks + -> mkVarSet [ v | TyVarTy v <- xs ] + _ -> noKindTyVars ts f + in unionVarSets (func : args) +noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t +noKindTyVars ts (FunTy t1 t2) = noKindTyVars ts t1 `unionVarSet` noKindTyVars ts t2 +noKindTyVars ts (CastTy t _) = noKindTyVars ts t +noKindTyVars _ _ = emptyVarSet synifyPatSynType :: PatSyn -> LHsType GhcRn -synifyPatSynType ps = let - (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps - req_theta' | null req_theta && not (null prov_theta && null ex_tvs) = [unitTy] - -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>", - -- i.e., an explicit empty context, which is what we need. This is not - -- possible by taking theta = [], as that will print no context at all - | otherwise = req_theta - sForAll [] s = s - sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs - , hst_xforall = noExt - , hst_body = noLoc s } - sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta - , hst_xqual = noExt - , hst_body = noLoc s } - sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty - in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau +synifyPatSynType ps = + let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps + ts = maybeToList (tyConAppTyCon_maybe res_ty) + + -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>", + -- i.e., an explicit empty context, which is what we need. This is not + -- possible by taking theta = [], as that will print no context at all + req_theta' | null req_theta + , not (null prov_theta && null ex_tvs) + = [unitTy] + | otherwise = req_theta + + in implicitForAll ts [] (univ_tvs ++ ex_tvs) req_theta' + (\vs -> implicitForAll ts vs [] prov_theta (synifyType WithinType)) + (mkFunTys arg_tys res_ty) synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s synifyKindSig :: Kind -> LHsKind GhcRn -synifyKindSig k = synifyType WithinType k +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 +synifyInstHead (vs, preds, cls, types) = specializeInstHead $ InstHead { ihdClsName = getName cls , ihdTypes = map unLoc annot_ts , ihdInstType = ClassInst - { clsiCtx = map (unLoc . synifyType WithinType) preds + { clsiCtx = map (unLoc . synifyType WithinType []) preds , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon) , clsiSigs = map synifyClsIdSig $ classMethods cls , clsiAssocTys = do - (Right (FamDecl _ fam)) <- map (synifyTyCon Nothing) $ classATs cls + (Right (FamDecl _ fam)) <- map (synifyTyCon HideRuntimeRep Nothing) + (classATs cls) pure $ mkPseudoFamilyDecl fam } } where cls_tycon = classTyCon cls ts = filterOutInvisibleTypes cls_tycon types - ts' = map (synifyType WithinType) ts + ts' = map (synifyType WithinType vs) ts annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon) - synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification + synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs -- Convert a family instance, this could be a type family or data family synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GhcRn) @@ -623,9 +786,9 @@ synifyFamInst fi opaque = do where ityp SynFamilyInst | opaque = return $ TypeInst Nothing ityp SynFamilyInst = - return . TypeInst . Just . unLoc $ synifyType WithinType fam_rhs + return . TypeInst . Just . unLoc $ synifyType WithinType [] fam_rhs ityp (DataFamilyInst c) = - DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c + DataInst <$> synifyTyCon HideRuntimeRep (Just $ famInstAxiom fi) c fam_tc = famInstTyCon fi fam_flavor = fi_flavor fi fam_lhs = fi_tys fi @@ -645,7 +808,7 @@ synifyFamInst fi opaque = do = fam_lhs ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs - synifyTypes = map (synifyType WithinType) + synifyTypes = map (synifyType WithinType []) ts' = synifyTypes ts annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index a342de00..58cdd860 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-} +{-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -24,6 +24,7 @@ import Data.Char ( isSpace ) import Haddock.Types( DocNameI ) import Exception +import FV import Outputable ( Outputable, panic, showPpr ) import Name import NameSet @@ -33,6 +34,12 @@ import GHC import Class import DynFlags import SrcLoc ( advanceSrcLoc ) +import Var ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind, + isInvisibleArgFlag ) +import VarSet ( VarSet, emptyVarSet ) +import VarEnv ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) +import TyCoRep ( Type(..), isRuntimeRepVar ) +import TysWiredIn( liftedRepDataConTyCon ) import StringBuffer ( StringBuffer ) import qualified StringBuffer as S @@ -549,3 +556,104 @@ tryCppLine !loc !buf = spanSpace (S.prevChar buf '\n' == '\n') loc buf (c , b') -> spanCppLine (advanceSrcLoc l c) b' +------------------------------------------------------------------------------- +-- * Free variables of a 'Type' +------------------------------------------------------------------------------- + +-- | Get free type variables in a 'Type' in their order of appearance. +-- See [Ordering of implicit variables]. +orderedFVs + :: VarSet -- ^ free variables to ignore + -> [Type] -- ^ types to traverse (in order) looking for free variables + -> [TyVar] -- ^ free type variables, in the order they appear in +orderedFVs vs tys = + reverse . fst $ tyCoFVsOfTypes' tys (const True) vs ([], emptyVarSet) + + +-- See the "Free variables of types and coercions" section in 'TyCoRep', or +-- check out Note [Free variables of types]. The functions in this section +-- don't output type variables in the order they first appear in in the 'Type'. +-- +-- For example, 'tyCoVarsOfTypeList' reports an incorrect order for the type +-- of 'const :: a -> b -> a': +-- +-- >>> import Name +-- >>> import TyCoRep +-- >>> import TysPrim +-- >>> import Var +-- >>> a = TyVarTy alphaTyVar +-- >>> b = TyVarTy betaTyVar +-- >>> constTy = mkFunTys [a, b] a +-- >>> map (getOccString . tyVarName) (tyCoVarsOfTypeList constTy) +-- ["b","a"] +-- +-- However, we want to reuse the very optimized traversal machinery there, so +-- so we make our own `tyCoFVsOfType'`, `tyCoFVsBndr'`, and `tyCoVarsOfTypes'`. +-- All these do differently is traverse in a different order and ignore +-- coercion variables. + +-- | Just like 'tyCoFVsOfType', but traverses type variables in reverse order +-- of appearance. +tyCoFVsOfType' :: Type -> FV +tyCoFVsOfType' (TyVarTy v) a b c = (FV.unitFV v `unionFV` tyCoFVsOfType' (tyVarKind v)) a b c +tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c +tyCoFVsOfType' (LitTy {}) a b c = emptyFV a b c +tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c +tyCoFVsOfType' (FunTy arg res) a b c = (tyCoFVsOfType' res `unionFV` tyCoFVsOfType' arg) a b c +tyCoFVsOfType' (ForAllTy bndr ty) a b c = tyCoFVsBndr' bndr (tyCoFVsOfType' ty) a b c +tyCoFVsOfType' (CastTy ty _) a b c = (tyCoFVsOfType' ty) a b c +tyCoFVsOfType' (CoercionTy _ ) a b c = emptyFV a b c + +-- | Just like 'tyCoFVsOfTypes', but traverses type variables in reverse order +-- of appearance. +tyCoFVsOfTypes' :: [Type] -> FV +tyCoFVsOfTypes' (ty:tys) fv_cand in_scope acc = (tyCoFVsOfTypes' tys `unionFV` tyCoFVsOfType' ty) fv_cand in_scope acc +tyCoFVsOfTypes' [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc + +-- | Just like 'tyCoFVsBndr', but traverses type variables in reverse order of +-- appearance. +tyCoFVsBndr' :: TyVarBinder -> FV -> FV +tyCoFVsBndr' (Bndr tv _) fvs = FV.delFV tv fvs `unionFV` tyCoFVsOfType' (tyVarKind tv) + + +------------------------------------------------------------------------------- +-- * Defaulting RuntimeRep variables +------------------------------------------------------------------------------- + +-- | Traverses the type, defaulting type variables of kind 'RuntimeRep' to +-- 'LiftedType'. See 'defaultRuntimeRepVars' in IfaceType.hs the original such +-- function working over `IfaceType`'s. +defaultRuntimeRepVars :: Type -> Type +defaultRuntimeRepVars = go emptyVarEnv + where + go :: TyVarEnv () -> Type -> Type + go subs (ForAllTy (Bndr var flg) ty) + | isRuntimeRepVar var + , isInvisibleArgFlag flg + = let subs' = extendVarEnv subs var () + in go subs' ty + | otherwise + = ForAllTy (Bndr (updateTyVarKind (go subs) var) flg) + (go subs ty) + + go subs (TyVarTy tv) + | tv `elemVarEnv` subs + = TyConApp liftedRepDataConTyCon [] + | otherwise + = TyVarTy (updateTyVarKind (go subs) tv) + + go subs (TyConApp tc tc_args) + = TyConApp tc (map (go subs) tc_args) + + go subs (FunTy arg res) + = FunTy (go subs arg) (go subs res) + + go subs (AppTy t u) + = AppTy (go subs t) (go subs u) + + go subs (CastTy x co) + = CastTy (go subs x) co + + go _ ty@(LitTy {}) = ty + go _ ty@(CoercionTy {}) = ty + diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 36cfeaca..95245cb2 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -891,7 +891,7 @@ hiDecl dflags t = do Nothing -> do liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] return Nothing - Just x -> case tyThingToLHsDecl x of + Just x -> case tyThingToLHsDecl ShowRuntimeRep x of Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing Right (m, t') -> liftErrMsg (tell $ map bugWarn m) >> return (Just $ noLoc t') diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs index 4639253c..ff18cb40 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -1,22 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} module Haddock.Backends.Hyperlinker.ParserSpec (main, spec) where - import Test.Hspec import Test.QuickCheck -import qualified GHC +import GHC ( runGhc, getSessionDynFlags ) +import DynFlags ( CompilerInfo, DynFlags ) +import SysTools.Info ( getCompilerInfo' ) import Control.Monad.IO.Class +import Data.String ( fromString ) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS + import Haddock (getGhcDirs) import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types -withDynFlags :: (GHC.DynFlags -> IO ()) -> IO () +withDynFlags :: ((DynFlags, CompilerInfo) -> IO ()) -> IO () withDynFlags cont = do libDir <- fmap snd (getGhcDirs []) - GHC.runGhc (Just libDir) $ do - dflags <- GHC.getSessionDynFlags - liftIO $ cont dflags + runGhc (Just libDir) $ do + dflags <- getSessionDynFlags + cinfo <- liftIO $ getCompilerInfo' dflags + liftIO $ cont (dflags, cinfo) main :: IO () @@ -53,51 +60,60 @@ instance Arbitrary NoGhcRewrite where parseSpec :: Spec parseSpec = around withDynFlags $ do - it "is total" $ \dflags -> - property $ \src -> length (parse dflags "" src) `shouldSatisfy` (>= 0) + it "is total" $ \(dflags, cinfo) -> + property $ \src -> length (parse cinfo dflags "" (fromString src)) `shouldSatisfy` (>= 0) - it "retains file layout" $ \dflags -> - property $ \(NoGhcRewrite src) -> concatMap tkValue (parse dflags "" src) == src + it "retains file layout" $ \(dflags, cinfo) -> + property $ \(NoGhcRewrite src) -> + let orig = fromString src + lexed = BS.concat (map tkValue (parse cinfo dflags "" orig)) + in lexed == orig context "when parsing single-line comments" $ do - it "should ignore content until the end of line" $ \dflags -> + it "should ignore content until the end of line" $ \(dflags, cinfo) -> shouldParseTo "-- some very simple comment\nidentifier" [TkComment, TkSpace, TkIdentifier] + cinfo dflags - it "should allow endline escaping" $ \dflags -> + it "should allow endline escaping" $ \(dflags, cinfo) -> shouldParseTo "#define first line\\\nsecond line\\\nand another one" [TkCpp] + cinfo dflags context "when parsing multi-line comments" $ do - it "should support nested comments" $ \dflags -> + it "should support nested comments" $ \(dflags, cinfo) -> shouldParseTo "{- comment {- nested -} still comment -} {- next comment -}" [TkComment, TkSpace, TkComment] + cinfo dflags - it "should distinguish compiler pragma" $ \dflags -> + it "should distinguish compiler pragma" $ \(dflags, cinfo) -> shouldParseTo "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}" [TkComment, TkPragma, TkComment] + cinfo dflags - it "should recognize preprocessor directives" $ \dflags -> do + it "should recognize preprocessor directives" $ \(dflags, cinfo) -> do shouldParseTo "\n#define foo bar" - [TkSpace, TkCpp] + [TkCpp] + cinfo dflags shouldParseTo "x # y" [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier] + cinfo dflags - it "should distinguish basic language constructs" $ \dflags -> do + it "should distinguish basic language constructs" $ \(dflags, cinfo) -> do shouldParseTo "(* 2) <$> (\"abc\", foo)" @@ -105,6 +121,7 @@ parseSpec = around withDynFlags $ do , TkSpace, TkOperator, TkSpace , TkSpecial, TkString, TkSpecial, TkSpace, TkIdentifier, TkSpecial ] + cinfo dflags shouldParseTo @@ -114,6 +131,7 @@ parseSpec = around withDynFlags $ do , TkIdentifier, TkSpace, TkKeyword, TkSpace , TkIdentifier, TkSpace, TkOperator, TkSpace, TkIdentifier ] + cinfo dflags shouldParseTo @@ -124,9 +142,10 @@ parseSpec = around withDynFlags $ do , TkSpace, TkKeyword, TkSpace , TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier ] + cinfo dflags - it "should parse do-notation syntax" $ \dflags -> do + it "should parse do-notation syntax" $ \(dflags, cinfo) -> do shouldParseTo "do { foo <- getLine; putStrLn foo }" [ TkKeyword, TkSpace, TkSpecial, TkSpace @@ -134,10 +153,11 @@ parseSpec = around withDynFlags $ do , TkIdentifier, TkSpecial, TkSpace , TkIdentifier, TkSpace, TkIdentifier, TkSpace, TkSpecial ] + cinfo dflags shouldParseTo - (unlines + (fromString $ unlines [ "do" , " foo <- getLine" , " putStrLn foo" @@ -146,7 +166,10 @@ parseSpec = around withDynFlags $ do , TkSpace, TkGlyph, TkSpace, TkIdentifier, TkSpace , TkIdentifier, TkSpace, TkIdentifier, TkSpace ] + cinfo dflags where - shouldParseTo :: String -> [TokenType] -> GHC.DynFlags -> Expectation - shouldParseTo str tokens dflags = map tkType (parse dflags "" str) `shouldBe` tokens + shouldParseTo :: ByteString -> [TokenType] -> CompilerInfo -> DynFlags -> Expectation + shouldParseTo str tokens cinfo dflags = [ tkType tok + | tok <- parse cinfo dflags "" str + , not (BS.null (tkValue tok)) ] `shouldBe` tokens diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md index 971d8dc7..265579ca 100644 --- a/haddock-library/CHANGES.md +++ b/haddock-library/CHANGES.md @@ -1,7 +1,10 @@ -## TBA +## Changes in version 1.8.0 * Support inline markup in markdown-style links (#875) + * Remove now unused `Documentation.Haddock.Utf8` module. + This module was anyways copied from the `utf8-string` package. + ## Changes in version 1.7.0 * Make `Documentation.Haddock.Parser.Monad` an internal module diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index b19642ab..b24db5d4 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: haddock-library -version: 1.7.0 +version: 1.8.0 synopsis: Library exposing some functionality of Haddock. description: Haddock is a documentation-generation tool for Haskell @@ -45,7 +45,6 @@ library Documentation.Haddock.Markup Documentation.Haddock.Parser Documentation.Haddock.Types - Documentation.Haddock.Utf8 other-modules: Documentation.Haddock.Parser.Util @@ -71,8 +70,6 @@ test-suite spec Documentation.Haddock.Parser.UtilSpec Documentation.Haddock.ParserSpec Documentation.Haddock.Types - Documentation.Haddock.Utf8 - Documentation.Haddock.Utf8Spec build-depends: , base-compat ^>= 0.9.3 || ^>= 0.10.0 diff --git a/haddock-library/src/Documentation/Haddock/Utf8.hs b/haddock-library/src/Documentation/Haddock/Utf8.hs deleted file mode 100644 index 3f75e53b..00000000 --- a/haddock-library/src/Documentation/Haddock/Utf8.hs +++ /dev/null @@ -1,74 +0,0 @@ -module Documentation.Haddock.Utf8 (encodeUtf8, decodeUtf8) where -import Data.Bits ((.|.), (.&.), shiftL, shiftR) -import qualified Data.ByteString as BS -import Data.Char (chr, ord) -import Data.Word (Word8) - --- | Helper that encodes and packs a 'String' into a 'BS.ByteString' -encodeUtf8 :: String -> BS.ByteString -encodeUtf8 = BS.pack . encode - --- | Helper that unpacks and decodes a 'BS.ByteString' into a 'String' -decodeUtf8 :: BS.ByteString -> String -decodeUtf8 = decode . BS.unpack - --- Copy/pasted functions from Codec.Binary.UTF8.String for encoding/decoding --- | Character to use when 'encode' or 'decode' fail for a byte. -replacementCharacter :: Char -replacementCharacter = '\xfffd' - --- | Encode a Haskell String to a list of Word8 values, in UTF8 format. -encode :: String -> [Word8] -encode = concatMap (map fromIntegral . go . ord) - where - go oc - | oc <= 0x7f = [oc] - - | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) - , 0x80 + oc .&. 0x3f - ] - - | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) - , 0x80 + ((oc `shiftR` 6) .&. 0x3f) - , 0x80 + oc .&. 0x3f - ] - | otherwise = [ 0xf0 + (oc `shiftR` 18) - , 0x80 + ((oc `shiftR` 12) .&. 0x3f) - , 0x80 + ((oc `shiftR` 6) .&. 0x3f) - , 0x80 + oc .&. 0x3f - ] - --- | Decode a UTF8 string packed into a list of Word8 values, directly to String -decode :: [Word8] -> String -decode [ ] = "" -decode (c:cs) - | c < 0x80 = chr (fromEnum c) : decode cs - | c < 0xc0 = replacementCharacter : decode cs - | c < 0xe0 = multi1 - | c < 0xf0 = multi_byte 2 0xf 0x800 - | c < 0xf8 = multi_byte 3 0x7 0x10000 - | c < 0xfc = multi_byte 4 0x3 0x200000 - | c < 0xfe = multi_byte 5 0x1 0x4000000 - | otherwise = replacementCharacter : decode cs - where - multi1 = case cs of - c1 : ds | c1 .&. 0xc0 == 0x80 -> - let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f) - in if d >= 0x000080 then toEnum d : decode ds - else replacementCharacter : decode ds - _ -> replacementCharacter : decode cs - - multi_byte :: Int -> Word8 -> Int -> String - multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask)) - where - aux 0 rs acc - | overlong <= acc && acc <= 0x10ffff && - (acc < 0xd800 || 0xdfff < acc) && - (acc < 0xfffe || 0xffff < acc) = chr acc : decode rs - | otherwise = replacementCharacter : decode rs - - aux n (r:rs) acc - | r .&. 0xc0 == 0x80 = aux (n-1) rs - $ shiftL acc 6 .|. fromEnum (r .&. 0x3f) - - aux _ rs _ = replacementCharacter : decode rs diff --git a/haddock-library/test/Documentation/Haddock/Utf8Spec.hs b/haddock-library/test/Documentation/Haddock/Utf8Spec.hs deleted file mode 100644 index 47e12704..00000000 --- a/haddock-library/test/Documentation/Haddock/Utf8Spec.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Documentation.Haddock.Utf8Spec (main, spec) where - -import Test.Hspec -import Test.QuickCheck -import Documentation.Haddock.Utf8 - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "decodeUtf8" $ do - it "is inverse to encodeUtf8" $ do - property $ \xs -> (decodeUtf8 . encodeUtf8) xs `shouldBe` xs diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs index d4520100..6c19dbca 100644 --- a/haddock-test/src/Test/Haddock/Xhtml.hs +++ b/haddock-test/src/Test/Haddock/Xhtml.hs @@ -8,7 +8,7 @@ module Test.Haddock.Xhtml ( Xml(..) , parseXml, dumpXml - , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter + , stripLinks, stripLinksWhen, stripAnchorsWhen, stripIdsWhen, stripFooter ) where import Data.Data ( Data(..), Typeable, eqT, (:~:)(..) ) @@ -62,6 +62,14 @@ stripAnchorsWhen p = | qName key == "name" && p val = attr { attrVal = "" } | otherwise = attr +stripIdsWhen :: (String -> Bool) -> Xml -> Xml +stripIdsWhen p = + processAnchors unname + where + unname attr@(Attr { attrKey = key, attrVal = val }) + | qName key == "id" && p val = attr { attrVal = "" } + | otherwise = attr + processAnchors :: (Attr -> Attr) -> Xml -> Xml processAnchors f = Xml . gmapEverywhere f . xmlElement diff --git a/haddock.cabal b/haddock.cabal index c9804ec6..d340073e 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -91,7 +91,6 @@ executable haddock Documentation.Haddock.Parser.Monad Documentation.Haddock.Types Documentation.Haddock.Doc - Documentation.Haddock.Utf8 Documentation.Haddock.Parser.Util Documentation.Haddock.Markup diff --git a/hoogle-test/ref/Bug873/test.txt b/hoogle-test/ref/Bug873/test.txt index 3c0e1870..68873317 100644 --- a/hoogle-test/ref/Bug873/test.txt +++ b/hoogle-test/ref/Bug873/test.txt @@ -21,7 +21,7 @@ module Bug873 -- Note that <tt>(<a>$</a>)</tt> is levity-polymorphic in its result -- type, so that <tt>foo <a>$</a> True</tt> where <tt>foo :: Bool -> -- Int#</tt> is well-typed. -($) :: () => (a -> b) -> a -> b +($) :: forall (r :: RuntimeRep) a (b :: TYPE r). (a -> b) -> a -> b infixr 0 $ ($$) :: (a -> b) -> a -> b infixr 0 $$ diff --git a/html-test/ref/Bug548.html b/html-test/ref/Bug548.html index cff64ca2..e040e603 100644 --- a/html-test/ref/Bug548.html +++ b/html-test/ref/Bug548.html @@ -148,7 +148,9 @@ ><p class="src" ><a href="#" >from1</a - > :: <a href="#" title="Bug548" + > :: <span class="keyword" + >forall</span + > (a0 :: k). <a href="#" title="Bug548" >WrappedArrow</a > a b a0 -> <a href="#" title="GHC.Generics" >Rep1</a @@ -160,7 +162,9 @@ ><p class="src" ><a href="#" >to1</a - > :: <a href="#" title="GHC.Generics" + > :: <span class="keyword" + >forall</span + > (a0 :: k). <a href="#" title="GHC.Generics" >Rep1</a > (<a href="#" title="Bug548" >WrappedArrow</a diff --git a/html-test/ref/Instances.html b/html-test/ref/Instances.html index 4f51f049..0cf0fc92 100644 --- a/html-test/ref/Instances.html +++ b/html-test/ref/Instances.html @@ -2038,8 +2038,6 @@ >Int</a > c <a href="#" title="Data.Bool" >Bool</a - > :: <a href="#" title="Data.Kind" - >Type</a > <a href="#" class="selflink" >#</a ></p @@ -2050,9 +2048,7 @@ >Thud</a > <a href="#" title="Data.Int" >Int</a - > c :: <a href="#" title="Data.Kind" - >Type</a - > <a href="#" class="selflink" + > c <a href="#" class="selflink" >#</a ></p ></div @@ -2112,9 +2108,7 @@ >type</span > <a href="#" title="Instances" >Plugh</a - > [a] c [b] :: <a href="#" title="Data.Kind" - >Type</a - > <a href="#" class="selflink" + > [a] c [b] <a href="#" class="selflink" >#</a ></p ><p class="src" @@ -2122,9 +2116,7 @@ >data</span > <a href="#" title="Instances" >Thud</a - > [a] c :: <a href="#" title="Data.Kind" - >Type</a - > <a href="#" class="selflink" + > [a] c <a href="#" class="selflink" >#</a ></p ></div diff --git a/html-test/ref/Operators.html b/html-test/ref/Operators.html index 8c7746af..d0c42a08 100644 --- a/html-test/ref/Operators.html +++ b/html-test/ref/Operators.html @@ -96,9 +96,7 @@ >pattern</span > <a href="#" >(:+)</a - > :: <span class="keyword" - >forall</span - > a. a -> a -> [a]</li + > :: a -> a -> [a]</li ><li class="src short" ><span class="keyword" >data</span @@ -285,9 +283,7 @@ >pattern</span > <a id="v::-43-" class="def" >(:+)</a - > :: <span class="keyword" - >forall</span - > a. a -> a -> [a] <span class="fixity" + > :: a -> a -> [a] <span class="fixity" >infixr 3</span ><span class="rightedge" ></span @@ -529,4 +525,4 @@ ></div ></body ></html -> +>
\ No newline at end of file diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html index af6d0210..6b4f8fda 100644 --- a/html-test/ref/PatternSyns.html +++ b/html-test/ref/PatternSyns.html @@ -68,9 +68,7 @@ >pattern</span > <a href="#" >Foo</a - > :: <span class="keyword" - >forall</span - > x. x -> <a href="#" title="PatternSyns" + > :: x -> <a href="#" title="PatternSyns" >FooType</a > x</li ><li class="src short" @@ -78,9 +76,7 @@ >pattern</span > <a href="#" >Bar</a - > :: <span class="keyword" - >forall</span - > x. x -> <a href="#" title="PatternSyns" + > :: x -> <a href="#" title="PatternSyns" >FooType</a > (<a href="#" title="PatternSyns" >FooType</a @@ -90,9 +86,7 @@ >pattern</span > <a href="#" >(:<->)</a - > :: <span class="keyword" - >forall</span - > x x1. x -> x1 -> (<a href="#" title="PatternSyns" + > :: x -> x1 -> (<a href="#" title="PatternSyns" >FooType</a > x, <a href="#" title="PatternSyns" >FooType</a @@ -114,9 +108,7 @@ >pattern</span > <a href="#" >Blub</a - > :: () => <span class="keyword" - >forall</span - > x. <a href="#" title="Text.Show" + > :: () => <a href="#" title="Text.Show" >Show</a > x => x -> <a href="#" title="PatternSyns" >BlubType</a @@ -134,9 +126,7 @@ >pattern</span > <a href="#" >E</a - > :: <span class="keyword" - >forall</span - > k a (b :: k). a <a href="#" title="PatternSyns" + > :: a <a href="#" title="PatternSyns" >><</a > b</li ><li class="src short" @@ -189,9 +179,7 @@ >pattern</span > <a id="v:Foo" class="def" >Foo</a - > :: <span class="keyword" - >forall</span - > x. x -> <a href="#" title="PatternSyns" + > :: x -> <a href="#" title="PatternSyns" >FooType</a > x <a href="#" class="selflink" >#</a @@ -211,9 +199,7 @@ >pattern</span > <a id="v:Bar" class="def" >Bar</a - > :: <span class="keyword" - >forall</span - > x. x -> <a href="#" title="PatternSyns" + > :: x -> <a href="#" title="PatternSyns" >FooType</a > (<a href="#" title="PatternSyns" >FooType</a @@ -235,9 +221,7 @@ >pattern</span > <a id="v::-60--45--62-" class="def" >(:<->)</a - > :: <span class="keyword" - >forall</span - > x x1. x -> x1 -> (<a href="#" title="PatternSyns" + > :: x -> x1 -> (<a href="#" title="PatternSyns" >FooType</a > x, <a href="#" title="PatternSyns" >FooType</a @@ -291,9 +275,7 @@ >pattern</span > <a id="v:Blub" class="def" >Blub</a - > :: () => <span class="keyword" - >forall</span - > x. <a href="#" title="Text.Show" + > :: () => <a href="#" title="Text.Show" >Show</a > x => x -> <a href="#" title="PatternSyns" >BlubType</a @@ -347,9 +329,7 @@ >pattern</span > <a id="v:E" class="def" >E</a - > :: <span class="keyword" - >forall</span - > k a (b :: k). a <a href="#" title="PatternSyns" + > :: a <a href="#" title="PatternSyns" >><</a > b <a href="#" class="selflink" >#</a @@ -388,4 +368,4 @@ ></div ></body ></html -> +>
\ No newline at end of file diff --git a/html-test/ref/TypeFamilies.html b/html-test/ref/TypeFamilies.html index 492b7ec1..8e1e7364 100644 --- a/html-test/ref/TypeFamilies.html +++ b/html-test/ref/TypeFamilies.html @@ -286,8 +286,6 @@ >AssocD</a > <a href="#" title="TypeFamilies" >X</a - > :: <a href="#" title="Data.Kind" - >Type</a > <a href="#" class="selflink" >#</a ></p @@ -298,8 +296,6 @@ >AssocT</a > <a href="#" title="TypeFamilies" >X</a - > :: <a href="#" title="Data.Kind" - >Type</a > <a href="#" class="selflink" >#</a ></p @@ -720,8 +716,6 @@ >AssocD</a > <a href="#" title="TypeFamilies" >Y</a - > :: <a href="#" title="Data.Kind" - >Type</a > <a href="#" class="selflink" >#</a ></p @@ -732,8 +726,6 @@ >AssocT</a > <a href="#" title="TypeFamilies" >Y</a - > :: <a href="#" title="Data.Kind" - >Type</a > <a href="#" class="selflink" >#</a ></p @@ -1107,11 +1099,7 @@ ><li class="inst" ><a id="v:BatZ1" class="def" >BatZ1</a - > :: <span class="keyword" - >forall</span - > (z :: <a href="#" title="TypeFamilies" - >Z</a - >). <a href="#" title="TypeFamilies" + > :: <a href="#" title="TypeFamilies" >Z</a > -> <a href="#" title="TypeFamilies" >Bat</a @@ -1121,11 +1109,7 @@ ><li class="inst" ><a id="v:BatZ2" class="def" >BatZ2</a - > :: <span class="keyword" - >forall</span - > (z :: <a href="#" title="TypeFamilies" - >Z</a - >). {..} -> <a href="#" title="TypeFamilies" + > :: {..} -> <a href="#" title="TypeFamilies" >Bat</a > '<a href="#" title="TypeFamilies" >ZB</a @@ -1393,11 +1377,7 @@ ><li class="inst" ><a id="v:BatZ1" class="def" >BatZ1</a - > :: <span class="keyword" - >forall</span - > (z :: <a href="#" title="TypeFamilies" - >Z</a - >). <a href="#" title="TypeFamilies" + > :: <a href="#" title="TypeFamilies" >Z</a > -> <a href="#" title="TypeFamilies" >Bat</a @@ -1407,11 +1387,7 @@ ><li class="inst" ><a id="v:BatZ2" class="def" >BatZ2</a - > :: <span class="keyword" - >forall</span - > (z :: <a href="#" title="TypeFamilies" - >Z</a - >). {..} -> <a href="#" title="TypeFamilies" + > :: {..} -> <a href="#" title="TypeFamilies" >Bat</a > '<a href="#" title="TypeFamilies" >ZB</a @@ -1620,8 +1596,6 @@ >AssocD</a > <a href="#" title="TypeFamilies" >Y</a - > :: <a href="#" title="Data.Kind" - >Type</a > <a href="#" class="selflink" >#</a ></p @@ -1632,8 +1606,6 @@ >AssocT</a > <a href="#" title="TypeFamilies" >Y</a - > :: <a href="#" title="Data.Kind" - >Type</a > <a href="#" class="selflink" >#</a ></p @@ -1678,8 +1650,6 @@ >AssocD</a > <a href="#" title="TypeFamilies" >X</a - > :: <a href="#" title="Data.Kind" - >Type</a > <a href="#" class="selflink" >#</a ></p @@ -1690,8 +1660,6 @@ >AssocT</a > <a href="#" title="TypeFamilies" >X</a - > :: <a href="#" title="Data.Kind" - >Type</a > <a href="#" class="selflink" >#</a ></p diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs index d3ab79a8..1963753d 100644 --- a/hypsrc-test/Main.hs +++ b/hypsrc-test/Main.hs @@ -15,14 +15,23 @@ import Test.Haddock.Xhtml checkConfig :: CheckConfig Xml checkConfig = CheckConfig { ccfgRead = parseXml - , ccfgClean = \_ -> strip + , ccfgClean = strip , ccfgDump = dumpXml , ccfgEqual = (==) `on` dumpXml } where - strip = stripAnchors' . stripLinks' . stripFooter + -- The whole point of the ClangCppBug is to demonstrate a situation where + -- line numbers may vary (and test that links still work). Consequently, we + -- strip out line numbers for this test case. + strip f | takeBaseName f == "ClangCppBug" + = stripAnchors' . stripLinks' . stripIds' . stripIds'' . stripFooter + | otherwise + = stripAnchors' . stripLinks' . stripIds' . stripFooter + stripLinks' = stripLinksWhen $ \href -> "#local-" `isPrefixOf` href stripAnchors' = stripAnchorsWhen $ \name -> "local-" `isPrefixOf` name + stripIds' = stripIdsWhen $ \name -> "local-" `isPrefixOf` name + stripIds'' = stripIdsWhen $ \name -> "line-" `isPrefixOf` name dirConfig :: DirConfig diff --git a/hypsrc-test/ref/src/ClangCppBug.html b/hypsrc-test/ref/src/ClangCppBug.html index 42d0cfc0..d03c92e1 100644 --- a/hypsrc-test/ref/src/ClangCppBug.html +++ b/hypsrc-test/ref/src/ClangCppBug.html @@ -11,7 +11,7 @@ ><span > </span - ><span id="line-2" + ><span id="" ></span ><span class="hs-keyword" >module</span @@ -26,12 +26,12 @@ ><span > </span - ><span id="line-3" + ><span id="" ></span ><span > </span - ><span id="line-4" + ><span id="" ></span ><span class="annot" ><a href="ClangCppBug.html#foo" @@ -52,7 +52,7 @@ ><span > </span - ><span id="line-5" + ><span id="" ></span ><span id="foo" ><span class="annot" @@ -78,12 +78,12 @@ ><span > </span - ><span id="line-6" + ><span id="" ></span ><span > </span - ><span id="line-7" + ><span id="" ></span ><span class="hs-comment" >-- Clang doesn't mind these:</span @@ -108,12 +108,12 @@ ><span > </span - ><span id="line-10" + ><span id="" ></span ><span > </span - ><span id="line-11" + ><span id="" ></span ><span class="annot" ><a href="ClangCppBug.html#bar" @@ -134,7 +134,7 @@ ><span > </span - ><span id="line-12" + ><span id="" ></span ><span id="bar" ><span class="annot" @@ -160,26 +160,26 @@ ><span > </span - ><span id="line-13" + ><span id="" ></span ><span > </span - ><span id="line-14" + ><span id="" ></span ><span class="hs-comment" >-- But it doesn't like this:</span ><span > </span - ><span id="line-15" + ><span id="" ></span ><span class="hs-pragma" >{-# RULES</span ><span > </span - ><span id="line-16" + ><span id="" ></span ><span class="annot" ><span class="hs-pragma" @@ -208,7 +208,7 @@ ><span > </span - ><span id="line-17" + ><span id="" ></span ><span class="annot" ><span class="hs-pragma" @@ -237,7 +237,7 @@ ><span > </span - ><span id="line-18" + ><span id="" ></span ><span > </span @@ -246,12 +246,12 @@ ><span > </span - ><span id="line-20" + ><span id="" ></span ><span > </span - ><span id="line-21" + ><span id="" ></span ><span class="annot" ><a href="ClangCppBug.html#qux" @@ -272,7 +272,7 @@ ><span > </span - ><span id="line-22" + ><span id="" ></span ><span id="qux" ><span class="annot" @@ -298,7 +298,7 @@ ><span > </span - ><span id="line-23" + ><span id="" ></span ></pre ></body diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html index dd1e6ebc..443d7f96 100644 --- a/hypsrc-test/ref/src/Classes.html +++ b/hypsrc-test/ref/src/Classes.html @@ -45,7 +45,7 @@ ></span ><span > </span - ><span id="local-6989586621679043524" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -182,7 +182,7 @@ ></span ><span > </span - ><span id="local-6989586621679043488" + ><span id="" ><span class="annot" ><span class="annottext" >bar :: Int -> Int @@ -214,7 +214,7 @@ forall a. a -> a ></span ><span > </span - ><span id="local-6989586621679043486" + ><span id="" ><span class="annot" ><span class="annottext" >baz :: Int -> (Int, Int) @@ -227,7 +227,7 @@ forall a. a -> a ></span ><span > </span - ><span id="local-6989586621679043485" + ><span id="" ><span class="annot" ><span class="annottext" >x :: Int @@ -280,7 +280,7 @@ forall a. a -> a </span ><span id="line-12" ></span - ><span id="local-6989586621679043484" + ><span id="" ><span class="hs-keyword" >instance</span ><span @@ -314,7 +314,7 @@ forall a. a -> a ></span ><span > </span - ><span id="local-6989586621679043481" + ><span id="" ><span class="annot" ><span class="annottext" >bar :: [a] -> Int @@ -346,7 +346,7 @@ forall (t :: * -> *) a. Foldable t => t a -> Int ></span ><span > </span - ><span id="local-6989586621679043479" + ><span id="" ><span class="annot" ><span class="annottext" >baz :: Int -> ([a], [a]) @@ -433,7 +433,7 @@ forall (t :: * -> *) a. Foldable t => t a -> Int ></span ><span > </span - ><span id="local-6989586621679043519" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -505,7 +505,7 @@ forall (t :: * -> *) a. Foldable t => t a -> Int ></span ><span > </span - ><span id="local-6989586621679043477" + ><span id="" ><span class="annot" ><a href="Classes.html#quux" ><span class="hs-identifier hs-var hs-var" @@ -516,7 +516,7 @@ forall (t :: * -> *) a. Foldable t => t a -> Int > </span ><span class="hs-special" >(</span - ><span id="local-6989586621679043476" + ><span id="" ><span class="annot" ><span class="annottext" >x :: a @@ -531,7 +531,7 @@ forall (t :: * -> *) a. Foldable t => t a -> Int >,</span ><span > </span - ><span id="local-6989586621679043475" + ><span id="" ><span class="annot" ><span class="annottext" >y :: a @@ -644,7 +644,7 @@ forall a. Foo' a => [a] -> a ></span ><span > </span - ><span id="local-6989586621679043473" + ><span id="" ><span class="annot" ><a href="Classes.html#norf" ><span class="hs-identifier hs-var hs-var" @@ -756,7 +756,7 @@ forall a. Foo a => a -> Int >instance</span ><span > </span - ><span id="local-6989586621679043468" + ><span id="" ><span class="annot" ><a href="Classes.html#Foo%27" ><span class="hs-identifier hs-type" @@ -781,7 +781,7 @@ forall a. Foo a => a -> Int ></span ><span > </span - ><span id="local-6989586621679043465" + ><span id="" ><span class="annot" ><span class="annottext" >norf :: [Int] -> Int @@ -816,12 +816,12 @@ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a </span ><span id="line-27" ></span - ><span id="local-6989586621679043464" + ><span id="" ><span class="hs-keyword" >instance</span ><span > </span - ><span id="local-6989586621679043460" + ><span id="" ><span class="annot" ><a href="Classes.html#Foo%27" ><span class="hs-identifier hs-type" @@ -852,7 +852,7 @@ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a ></span ><span > </span - ><span id="local-6989586621679043459" + ><span id="" ><span class="annot" ><span class="annottext" >quux :: ([a], [a]) -> [a] @@ -917,7 +917,7 @@ forall a. [a] -> [a] -> [a] ></span ><span > </span - ><span id="local-6989586621679043503" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -936,8 +936,8 @@ forall a. [a] -> [a] -> [a] ></span ><span > </span - ><span id="local-6989586621679043505" - ><span id="local-6989586621679043506" + ><span id="" + ><span id="" ><span id="plugh" ><span class="annot" ><a href="Classes.html#plugh" @@ -1101,7 +1101,7 @@ forall a. [a] -> [a] -> [a] ></span ><span > </span - ><span id="local-6989586621679043454" + ><span id="" ><span class="annot" ><span class="annottext" >plugh :: Either a a -> Either b b -> Either (a -> b) (b -> a) @@ -1122,7 +1122,7 @@ forall a. [a] -> [a] -> [a] ></span ><span > </span - ><span id="local-6989586621679043453" + ><span id="" ><span class="annot" ><span class="annottext" >a :: a @@ -1208,7 +1208,7 @@ forall a b. a -> b -> a ></span ><span > </span - ><span id="local-6989586621679043451" + ><span id="" ><span class="annot" ><span class="annottext" >a :: a @@ -1298,7 +1298,7 @@ forall a b. a -> b -> a ></span ><span > </span - ><span id="local-6989586621679043450" + ><span id="" ><span class="annot" ><span class="annottext" >b :: b @@ -1384,7 +1384,7 @@ forall a b. a -> b -> a ></span ><span > </span - ><span id="local-6989586621679043449" + ><span id="" ><span class="annot" ><span class="annottext" >b :: b diff --git a/hypsrc-test/ref/src/Constructors.html b/hypsrc-test/ref/src/Constructors.html index 6cdf07db..970ec741 100644 --- a/hypsrc-test/ref/src/Constructors.html +++ b/hypsrc-test/ref/src/Constructors.html @@ -478,7 +478,7 @@ ></span ><span > </span - ><span id="local-6989586621679043545" + ><span id="" ><span class="annot" ><span class="annottext" >foo :: Foo @@ -491,7 +491,7 @@ ></span ><span > </span - ><span id="local-6989586621679043544" + ><span id="" ><span class="annot" ><span class="annottext" >n :: Int @@ -656,7 +656,7 @@ forall a. Num a => a -> a -> a >,</span ><span > </span - ><span id="local-6989586621679043540" + ><span id="" ><span class="annot" ><span class="annottext" >xs :: [Foo] @@ -731,7 +731,7 @@ forall a. Num a => a -> a -> a >,</span ><span > </span - ><span id="local-6989586621679043539" + ><span id="" ><span class="annot" ><span class="annottext" >xs :: [Foo] @@ -871,7 +871,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043535" + ><span id="" ><span class="annot" ><span class="annottext" >x :: Norf @@ -896,7 +896,7 @@ forall a. HasCallStack => a > </span ><span class="hs-special" >(</span - ><span id="local-6989586621679043534" + ><span id="" ><span class="annot" ><span class="annottext" >f1 :: Foo @@ -923,7 +923,7 @@ forall a. HasCallStack => a >_</span ><span > </span - ><span id="local-6989586621679043533" + ><span id="" ><span class="annot" ><span class="annottext" >n :: Int @@ -946,7 +946,7 @@ forall a. HasCallStack => a >,</span ><span > </span - ><span id="local-6989586621679043532" + ><span id="" ><span class="annot" ><span class="annottext" >f2 :: Foo @@ -969,7 +969,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043531" + ><span id="" ><span class="annot" ><span class="annottext" >f3 :: Foo @@ -1111,7 +1111,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043529" + ><span id="" ><span class="annot" ><span class="annottext" >aux :: Foo -> Int @@ -1124,7 +1124,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043528" + ><span id="" ><span class="annot" ><span class="annottext" >fx :: Foo @@ -1232,7 +1232,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043530" + ><span id="" ><span class="annot" ><span class="annottext" >x' :: Int diff --git a/hypsrc-test/ref/src/Identifiers.html b/hypsrc-test/ref/src/Identifiers.html index 301761c1..5268031d 100644 --- a/hypsrc-test/ref/src/Identifiers.html +++ b/hypsrc-test/ref/src/Identifiers.html @@ -105,7 +105,7 @@ ></span ><span > </span - ><span id="local-6989586621679043592" + ><span id="" ><span class="annot" ><span class="annottext" >x :: Int @@ -118,7 +118,7 @@ ></span ><span > </span - ><span id="local-6989586621679043591" + ><span id="" ><span class="annot" ><span class="annottext" >y :: Int @@ -268,7 +268,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043588" + ><span id="" ><span class="annot" ><span class="annottext" >x :: Int @@ -281,7 +281,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043587" + ><span id="" ><span class="annot" ><span class="annottext" >y :: Int @@ -431,7 +431,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043586" + ><span id="" ><span class="annot" ><span class="annottext" >x :: Int @@ -444,7 +444,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043585" + ><span id="" ><span class="annot" ><span class="annottext" >y :: Int @@ -608,7 +608,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043583" + ><span id="" ><span class="annot" ><span class="annottext" >x :: Int @@ -782,7 +782,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043581" + ><span id="" ><span class="annot" ><span class="annottext" >x :: Int @@ -795,7 +795,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043580" + ><span id="" ><span class="annot" ><span class="annottext" >y :: Int @@ -808,7 +808,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043579" + ><span id="" ><span class="annot" ><span class="annottext" >z :: Int @@ -1397,7 +1397,7 @@ forall a b. (a -> b) -> a -> b ></span ><span > </span - ><span id="local-6989586621679043573" + ><span id="" ><span class="annot" ><span class="annottext" >x :: Int @@ -1425,7 +1425,7 @@ forall a b. (a -> b) -> a -> b ></span ><span > </span - ><span id="local-6989586621679043572" + ><span id="" ><span class="annot" ><span class="annottext" >y :: Int @@ -1453,7 +1453,7 @@ forall a b. (a -> b) -> a -> b ></span ><span > </span - ><span id="local-6989586621679043571" + ><span id="" ><span class="annot" ><span class="annottext" >z :: Int diff --git a/hypsrc-test/ref/src/LinkingIdentifiers.html b/hypsrc-test/ref/src/LinkingIdentifiers.html index 2ef590bd..52b20200 100644 --- a/hypsrc-test/ref/src/LinkingIdentifiers.html +++ b/hypsrc-test/ref/src/LinkingIdentifiers.html @@ -102,7 +102,7 @@ </span ><span id="line-9" ></span - ><span id="local-6989586621679043611" + ><span id="" ><span class="annot" ><span class="annottext" >x :: Int @@ -221,7 +221,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043609" + ><span id="" ><span class="annot" ><span class="annottext" >x :: Int @@ -357,7 +357,7 @@ forall a. Num a => a -> a -> a </span ><span id="line-13" ></span - ><span id="local-6989586621679043607" + ><span id="" ><span class="annot" ><span class="annottext" >x :: Int @@ -476,7 +476,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043606" + ><span id="" ><span class="annot" ><span class="annottext" >x :: Int diff --git a/hypsrc-test/ref/src/Literals.html b/hypsrc-test/ref/src/Literals.html index 62ea32dd..f0d05fbc 100644 --- a/hypsrc-test/ref/src/Literals.html +++ b/hypsrc-test/ref/src/Literals.html @@ -83,7 +83,7 @@ </span ><span id="line-7" ></span - ><span id="local-6989586621679043622" + ><span id="" ><span class="annot" ><a href="Literals.html#num" ><span class="hs-identifier hs-type" @@ -221,7 +221,7 @@ forall a. Num a => a -> a -> a </span ><span id="line-10" ></span - ><span id="local-6989586621679043618" + ><span id="" ><span class="annot" ><a href="Literals.html#frac" ><span class="hs-identifier hs-type" @@ -295,7 +295,7 @@ forall a. Num a => a -> a -> a </span ><span id="line-13" ></span - ><span id="local-6989586621679043616" + ><span id="" ><span class="annot" ><a href="Literals.html#list" ><span class="hs-identifier hs-type" diff --git a/hypsrc-test/ref/src/Operators.html b/hypsrc-test/ref/src/Operators.html index 403954cf..4d5693c2 100644 --- a/hypsrc-test/ref/src/Operators.html +++ b/hypsrc-test/ref/src/Operators.html @@ -31,7 +31,7 @@ </span ><span id="line-4" ></span - ><span id="local-6989586621679043657" + ><span id="" ><span class="annot" ><a href="Operators.html#%2B%2B%2B" ><span class="hs-operator hs-type" @@ -92,7 +92,7 @@ </span ><span id="line-5" ></span - ><span id="local-6989586621679043655" + ><span id="" ><span class="annot" ><span class="annottext" >a :: [a] @@ -118,7 +118,7 @@ ></span ><span > </span - ><span id="local-6989586621679043654" + ><span id="" ><span class="annot" ><span class="annottext" >b :: [a] @@ -196,7 +196,7 @@ forall a. [a] -> [a] -> [a] </span ><span id="line-7" ></span - ><span id="local-6989586621679043653" + ><span id="" ><span class="annot" ><a href="Operators.html#%24%24%24" ><span class="hs-operator hs-type" @@ -257,7 +257,7 @@ forall a. [a] -> [a] -> [a] </span ><span id="line-8" ></span - ><span id="local-6989586621679043651" + ><span id="" ><span class="annot" ><span class="annottext" >a :: [a] @@ -283,7 +283,7 @@ forall a. [a] -> [a] -> [a] ></span ><span > </span - ><span id="local-6989586621679043650" + ><span id="" ><span class="annot" ><span class="annottext" >b :: [a] @@ -342,7 +342,7 @@ forall a. [a] -> [a] -> [a] </span ><span id="line-10" ></span - ><span id="local-6989586621679043649" + ><span id="" ><span class="annot" ><a href="Operators.html#%2A%2A%2A" ><span class="hs-operator hs-type" @@ -416,7 +416,7 @@ forall a. [a] -> [a] -> [a] ></span ><span > </span - ><span id="local-6989586621679043647" + ><span id="" ><span class="annot" ><span class="annottext" >a :: [a] @@ -461,7 +461,7 @@ forall a. [a] -> [a] -> [a] ></span ><span > </span - ><span id="local-6989586621679043646" + ><span id="" ><span class="annot" ><span class="annottext" >a :: [a] @@ -482,7 +482,7 @@ forall a. [a] -> [a] -> [a] ><span class="hs-glyph hs-type" >:</span ></span - ><span id="local-6989586621679043645" + ><span id="" ><span class="annot" ><span class="annottext" >b :: [a] @@ -570,7 +570,7 @@ forall a. [a] -> [a] -> [a] </span ><span id="line-14" ></span - ><span id="local-6989586621679043666" + ><span id="" ><span class="annot" ><a href="Operators.html#%2A%2F%5C%2A" ><span class="hs-operator hs-type" @@ -635,7 +635,7 @@ forall a. [a] -> [a] -> [a] </span ><span id="line-15" ></span - ><span id="local-6989586621679043643" + ><span id="" ><span class="annot" ><span class="annottext" >a :: [[a]] @@ -661,7 +661,7 @@ forall a. [a] -> [a] -> [a] ></span ><span > </span - ><span id="local-6989586621679043642" + ><span id="" ><span class="annot" ><span class="annottext" >b :: [a] @@ -734,7 +734,7 @@ forall a. [a] -> [a] -> [a] </span ><span id="line-17" ></span - ><span id="local-6989586621679043640" + ><span id="" ><span class="annot" ><a href="Operators.html#%2A%2A%2F%5C%2A%2A" ><span class="hs-operator hs-type" @@ -807,7 +807,7 @@ forall a. [a] -> [a] -> [a] </span ><span id="line-18" ></span - ><span id="local-6989586621679043638" + ><span id="" ><span class="annot" ><span class="annottext" >a :: [[a]] @@ -833,7 +833,7 @@ forall a. [a] -> [a] -> [a] ></span ><span > </span - ><span id="local-6989586621679043637" + ><span id="" ><span class="annot" ><span class="annottext" >b :: [[a]] @@ -961,9 +961,9 @@ forall a. [a] -> [a] -> [a] </span ><span id="line-21" ></span - ><span id="local-6989586621679043633" - ><span id="local-6989586621679043634" - ><span id="local-6989586621679043635" + ><span id="" + ><span id="" + ><span id="" ><span class="annot" ><a href="Operators.html#%23.%23" ><span class="hs-operator hs-type" @@ -1044,7 +1044,7 @@ forall a. [a] -> [a] -> [a] </span ><span id="line-22" ></span - ><span id="local-6989586621679043631" + ><span id="" ><span class="annot" ><span class="annottext" >a :: a @@ -1070,7 +1070,7 @@ forall a. [a] -> [a] -> [a] ></span ><span > </span - ><span id="local-6989586621679043630" + ><span id="" ><span class="annot" ><span class="annottext" >b :: b diff --git a/hypsrc-test/ref/src/Polymorphism.html b/hypsrc-test/ref/src/Polymorphism.html index 91f8bd33..ec9c49e8 100644 --- a/hypsrc-test/ref/src/Polymorphism.html +++ b/hypsrc-test/ref/src/Polymorphism.html @@ -55,7 +55,7 @@ </span ><span id="line-8" ></span - ><span id="local-6989586621679043738" + ><span id="" ><span class="annot" ><a href="Polymorphism.html#foo" ><span class="hs-identifier hs-type" @@ -155,7 +155,7 @@ forall a. HasCallStack => a >forall</span ><span > </span - ><span id="local-6989586621679043734" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -237,8 +237,8 @@ forall a. HasCallStack => a </span ><span id="line-14" ></span - ><span id="local-6989586621679043732" - ><span id="local-6989586621679043733" + ><span id="" + ><span id="" ><span class="annot" ><a href="Polymorphism.html#bar" ><span class="hs-identifier hs-type" @@ -353,7 +353,7 @@ forall a. HasCallStack => a >forall</span ><span > </span - ><span id="local-6989586621679043729" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -363,7 +363,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043728" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -459,8 +459,8 @@ forall a. HasCallStack => a </span ><span id="line-20" ></span - ><span id="local-6989586621679043726" - ><span id="local-6989586621679043727" + ><span id="" + ><span id="" ><span class="annot" ><a href="Polymorphism.html#baz" ><span class="hs-identifier hs-type" @@ -605,7 +605,7 @@ forall a. HasCallStack => a >forall</span ><span > </span - ><span id="local-6989586621679043723" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -615,7 +615,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043722" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -741,7 +741,7 @@ forall a. HasCallStack => a </span ><span id="line-26" ></span - ><span id="local-6989586621679043721" + ><span id="" ><span class="annot" ><a href="Polymorphism.html#quux" ><span class="hs-identifier hs-type" @@ -772,7 +772,7 @@ forall a. HasCallStack => a >forall</span ><span > </span - ><span id="local-6989586621679043756" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -835,7 +835,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043719" + ><span id="" ><span class="annot" ><span class="annottext" >x :: a @@ -848,7 +848,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043718" + ><span id="" ><span class="annot" ><span class="annottext" >f :: forall a. a -> a @@ -912,7 +912,7 @@ forall a. a -> a >forall</span ><span > </span - ><span id="local-6989586621679043716" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -942,7 +942,7 @@ forall a. a -> a >forall</span ><span > </span - ><span id="local-6989586621679043715" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -1004,7 +1004,7 @@ forall a. a -> a ></span ><span > </span - ><span id="local-6989586621679043714" + ><span id="" ><span class="annot" ><span class="annottext" >x :: a @@ -1017,7 +1017,7 @@ forall a. a -> a ></span ><span > </span - ><span id="local-6989586621679043713" + ><span id="" ><span class="annot" ><span class="annottext" >f :: forall a. a -> a @@ -1070,7 +1070,7 @@ forall a. a -> a </span ><span id="line-33" ></span - ><span id="local-6989586621679043712" + ><span id="" ><span class="annot" ><a href="Polymorphism.html#num" ><span class="hs-identifier hs-type" @@ -1188,7 +1188,7 @@ forall a. HasCallStack => a >forall</span ><span > </span - ><span id="local-6989586621679043709" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -1288,8 +1288,8 @@ forall a. HasCallStack => a </span ><span id="line-39" ></span - ><span id="local-6989586621679043707" - ><span id="local-6989586621679043708" + ><span id="" + ><span id="" ><span class="annot" ><a href="Polymorphism.html#eq" ><span class="hs-identifier hs-type" @@ -1450,7 +1450,7 @@ forall a. HasCallStack => a >forall</span ><span > </span - ><span id="local-6989586621679043704" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -1460,7 +1460,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043703" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -1602,8 +1602,8 @@ forall a. HasCallStack => a </span ><span id="line-45" ></span - ><span id="local-6989586621679043701" - ><span id="local-6989586621679043702" + ><span id="" + ><span id="" ><span class="annot" ><a href="Polymorphism.html#mon" ><span class="hs-identifier hs-type" @@ -1742,7 +1742,7 @@ forall a. HasCallStack => a >forall</span ><span > </span - ><span id="local-6989586621679043698" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -1752,7 +1752,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043697" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -1877,7 +1877,7 @@ forall a. HasCallStack => a </span ><span id="line-52" ></span - ><span id="local-6989586621679043696" + ><span id="" ><span class="annot" ><a href="Polymorphism.html#norf" ><span class="hs-identifier hs-type" @@ -1908,7 +1908,7 @@ forall a. HasCallStack => a >forall</span ><span > </span - ><span id="local-6989586621679043743" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -1989,7 +1989,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043694" + ><span id="" ><span class="annot" ><span class="annottext" >x :: a @@ -2002,7 +2002,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043693" + ><span id="" ><span class="annot" ><span class="annottext" >f :: forall a. Ord a => a -> a @@ -2054,7 +2054,7 @@ forall a. HasCallStack => a >forall</span ><span > </span - ><span id="local-6989586621679043691" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -2084,7 +2084,7 @@ forall a. HasCallStack => a >forall</span ><span > </span - ><span id="local-6989586621679043690" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -2164,7 +2164,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043689" + ><span id="" ><span class="annot" ><span class="annottext" >x :: a @@ -2177,7 +2177,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043688" + ><span id="" ><span class="annot" ><span class="annottext" >f :: forall a. Ord a => a -> a @@ -2234,7 +2234,7 @@ forall a. HasCallStack => a >forall</span ><span > </span - ><span id="local-6989586621679043686" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -2282,7 +2282,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043685" + ><span id="" ><span class="annot" ><span class="annottext" >x :: a @@ -2346,7 +2346,7 @@ forall a. HasCallStack => a >forall</span ><span > </span - ><span id="local-6989586621679043683" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -2356,7 +2356,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043682" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -2446,7 +2446,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043681" + ><span id="" ><span class="annot" ><span class="annottext" >f :: a -> b @@ -2459,7 +2459,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043680" + ><span id="" ><span class="annot" ><span class="annottext" >x :: a @@ -2561,7 +2561,7 @@ forall a. HasCallStack => a ></span ><span > </span - ><span id="local-6989586621679043679" + ><span id="" ><span class="annot" ><span class="annottext" >y :: b diff --git a/hypsrc-test/ref/src/Records.html b/hypsrc-test/ref/src/Records.html index bc99cc56..5057b8a4 100644 --- a/hypsrc-test/ref/src/Records.html +++ b/hypsrc-test/ref/src/Records.html @@ -229,7 +229,7 @@ ></span ><span > </span - ><span id="local-6989586621679043799" + ><span id="" ><span class="annot" ><span class="annottext" >x :: Int @@ -242,7 +242,7 @@ ></span ><span > </span - ><span id="local-6989586621679043798" + ><span id="" ><span class="annot" ><span class="annottext" >y :: Int @@ -420,7 +420,7 @@ >=</span ><span > </span - ><span id="local-6989586621679043795" + ><span id="" ><span class="annot" ><span class="annottext" >Int @@ -450,7 +450,7 @@ >=</span ><span > </span - ><span id="local-6989586621679043794" + ><span id="" ><span class="annot" ><span class="annottext" >Int @@ -615,7 +615,7 @@ forall a. Num a => a -> a -> a >{</span ><span > </span - ><span id="local-6989586621679043790" + ><span id="" ><span class="annot" ><span class="annottext" >Int @@ -632,7 +632,7 @@ x :: Point -> Int >,</span ><span > </span - ><span id="local-6989586621679043789" + ><span id="" ><span class="annot" ><span class="annottext" >Int @@ -812,7 +812,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043786" + ><span id="" ><span class="annot" ><span class="annottext" >p :: Point @@ -825,7 +825,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043785" + ><span id="" ><span class="annot" ><span class="annottext" >d :: Int @@ -935,7 +935,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043784" + ><span id="" ><span class="annot" ><span class="annottext" >p :: Point @@ -948,7 +948,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043783" + ><span id="" ><span class="annot" ><span class="annottext" >d :: Int @@ -1118,7 +1118,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043781" + ><span id="" ><span class="annot" ><span class="annottext" >x :: Int @@ -1131,7 +1131,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043780" + ><span id="" ><span class="annot" ><span class="annottext" >y :: Int @@ -1144,7 +1144,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043779" + ><span id="" ><span class="annot" ><span class="annottext" >p :: Point @@ -1204,7 +1204,7 @@ forall a. Num a => a -> a -> a > </span ><span class="hs-special" >(</span - ><span id="local-6989586621679043777" + ><span id="" ><span class="annot" ><span class="annottext" >dx :: Int @@ -1219,7 +1219,7 @@ forall a. Num a => a -> a -> a >,</span ><span > </span - ><span id="local-6989586621679043776" + ><span id="" ><span class="annot" ><span class="annottext" >dy :: Int @@ -1271,7 +1271,7 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043778" + ><span id="" ><span class="annot" ><span class="annottext" >aux :: Point -> Point @@ -1284,8 +1284,8 @@ forall a. Num a => a -> a -> a ></span ><span > </span - ><span id="local-6989586621679043774" - ><span id="local-6989586621679043775" + ><span id="" + ><span id="" ><span class="annot" ><a href="Records.html#Point" ><span class="hs-identifier hs-type" diff --git a/hypsrc-test/ref/src/Types.html b/hypsrc-test/ref/src/Types.html index 1258b8c1..22012ad1 100644 --- a/hypsrc-test/ref/src/Types.html +++ b/hypsrc-test/ref/src/Types.html @@ -254,7 +254,7 @@ ></span ><span > </span - ><span id="local-6989586621679043815" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -264,7 +264,7 @@ ></span ><span > </span - ><span id="local-6989586621679043814" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -444,7 +444,7 @@ ></span ><span > </span - ><span id="local-6989586621679043811" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" @@ -454,7 +454,7 @@ ></span ><span > </span - ><span id="local-6989586621679043810" + ><span id="" ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" |