diff --git a/.gitignore b/.gitignore index 327f01216e..d65138d11d 100644 --- a/.gitignore +++ b/.gitignore @@ -25,5 +25,7 @@ TAGS .cabal-sandbox .ghc.environment.* cabal.sandbox.config +cabal.project.local +cabal.project.local~ .stack-work/ diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 4aaaed9d7c..97c74771cc 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -155,7 +155,7 @@ synifyTyCon _coax tc -- 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 [] } @@ -210,7 +210,7 @@ synifyTyCon coax tc -- CoAxioms, not their TyCons _ -> synifyName tc tyvars = synifyTyVars (tyConTyVars tc) - kindSig = Just (tyConKind tc) + kindSig = synifyDataTyConReturnKind tc -- The data constructors. -- -- Any data-constructors not exported from the module that *defines* the @@ -235,7 +235,7 @@ synifyTyCon coax tc defn = HsDataDefn { dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing - , dd_kindSig = fmap synifyKindSig kindSig + , dd_kindSig = kindSig , dd_cons = cons , dd_derivs = alg_deriv } in case lefts consRaw of @@ -245,6 +245,27 @@ synifyTyCon coax tc , tcdDataCusk = False, tcdFVs = placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs +-- 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 :: *) +-- +-- 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 :: *) +-- :: * -> (* -> *) -> * -> * +-- +-- Which is entirely wrong (#548). We only want to display the *return* kind, +-- which this function obtains. +synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind Name) +synifyDataTyConReturnKind tc + = case splitFunTys (tyConKind tc) of + (_, ret_kind) + | isLiftedTypeKind ret_kind -> Nothing -- Don't bother displaying :: * + | otherwise -> Just (synifyKindSig ret_kind) + synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity -> Maybe (LInjectivityAnn Name) synifyInjectivityAnn Nothing _ _ = Nothing diff --git a/html-test/ref/Bug548.html b/html-test/ref/Bug548.html new file mode 100644 index 0000000000..1ae918780b --- /dev/null +++ b/html-test/ref/Bug548.html @@ -0,0 +1,600 @@ +Bug548

Safe HaskellSafe

Bug548

Documentation

newtype WrappedArrow (a :: * -> * -> *) b c #

Constructors

WrapArrow

Fields

Instances
Generic1 * (WrappedArrow a b)
Instance details

Associated Types

type Rep1 (WrappedArrow a b) (f :: WrappedArrow a b -> *) :: k -> * #

Methods

from1 :: f a0 -> Rep1 (WrappedArrow a b) f a0 #

to1 :: Rep1 (WrappedArrow a b) f a0 -> f a0 #

Arrow a => Functor (WrappedArrow a b)

Since: 2.1

Instance details

Methods

fmap :: (a0 -> b0) -> WrappedArrow a b a0 -> WrappedArrow a b b0 #

(<$) :: a0 -> WrappedArrow a b b0 -> WrappedArrow a b a0 #

Arrow a => Applicative (WrappedArrow a b)

Since: 2.1

Instance details

Methods

pure :: a0 -> WrappedArrow a b a0 #

(<*>) :: WrappedArrow a b (a0 -> b0) -> WrappedArrow a b a0 -> WrappedArrow a b b0 #

liftA2 :: (a0 -> b0 -> c) -> WrappedArrow a b a0 -> WrappedArrow a b b0 -> WrappedArrow a b c #

(*>) :: WrappedArrow a b a0 -> WrappedArrow a b b0 -> WrappedArrow a b b0 #

(<*) :: WrappedArrow a b a0 -> WrappedArrow a b b0 -> WrappedArrow a b a0 #

(ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b)

Since: 2.1

Instance details

Methods

empty :: WrappedArrow a b a0 #

(<|>) :: WrappedArrow a b a0 -> WrappedArrow a b a0 -> WrappedArrow a b a0 #

some :: WrappedArrow a b a0 -> WrappedArrow a b [a0] #

many :: WrappedArrow a b a0 -> WrappedArrow a b [a0] #

Generic (WrappedArrow a b c)
Instance details

Associated Types

type Rep (WrappedArrow a b c) :: * -> * #

Methods

from :: WrappedArrow a b c -> Rep (WrappedArrow a b c) x #

to :: Rep (WrappedArrow a b c) x -> WrappedArrow a b c #

type Rep1 * (WrappedArrow a b)
Instance details
type Rep1 * (WrappedArrow a b) = D1 * (MetaData "WrappedArrow" "Control.Applicative" "base" True) (C1 * (MetaCons "WrapArrow" PrefixI True) (S1 * (MetaSel (Just Symbol "unwrapArrow") NoSourceUnpackedness NoSourceStrictness DecidedLazy) (Rec1 * (a b))))
type Rep (WrappedArrow a b c)
Instance details
type Rep (WrappedArrow a b c) = D1 * (MetaData "WrappedArrow" "Control.Applicative" "base" True) (C1 * (MetaCons "WrapArrow" PrefixI True) (S1 * (MetaSel (Just Symbol "unwrapArrow") NoSourceUnpackedness NoSourceStrictness DecidedLazy) (Rec0 * (a b c))))
\ No newline at end of file diff --git a/html-test/src/Bug548.hs b/html-test/src/Bug548.hs new file mode 100644 index 0000000000..652d3d323c --- /dev/null +++ b/html-test/src/Bug548.hs @@ -0,0 +1,3 @@ +module Bug548 (WrappedArrow(..)) where + +import Control.Applicative