From a7a5ccec3fc44f3f2deab9ba32a5b9fe95aa9f6c Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 11 Nov 2018 20:00:30 -0800 Subject: Rename 'NewOcean' theme to 'Linuwial' --- html-test/ref/A.html | 4 ++-- html-test/ref/Bold.html | 4 ++-- html-test/ref/Bug1.html | 4 ++-- html-test/ref/Bug195.html | 4 ++-- html-test/ref/Bug2.html | 4 ++-- html-test/ref/Bug201.html | 4 ++-- html-test/ref/Bug253.html | 4 ++-- html-test/ref/Bug26.html | 2 +- html-test/ref/Bug280.html | 4 ++-- html-test/ref/Bug294.html | 2 +- html-test/ref/Bug298.html | 4 ++-- html-test/ref/Bug3.html | 4 ++-- html-test/ref/Bug308.html | 4 ++-- html-test/ref/Bug308CrossModule.html | 4 ++-- html-test/ref/Bug310.html | 2 +- html-test/ref/Bug313.html | 4 ++-- html-test/ref/Bug335.html | 4 ++-- html-test/ref/Bug387.html | 2 +- html-test/ref/Bug4.html | 4 ++-- html-test/ref/Bug458.html | 4 ++-- html-test/ref/Bug546.html | 4 ++-- html-test/ref/Bug548.html | 2 +- html-test/ref/Bug574.html | 2 +- html-test/ref/Bug6.html | 4 ++-- html-test/ref/Bug613.html | 2 +- html-test/ref/Bug647.html | 4 ++-- html-test/ref/Bug679.html | 2 +- html-test/ref/Bug7.html | 2 +- html-test/ref/Bug8.html | 4 ++-- html-test/ref/Bug85.html | 4 ++-- html-test/ref/Bug953.html | 4 ++-- html-test/ref/BugDeprecated.html | 4 ++-- html-test/ref/BugExportHeadings.html | 2 +- html-test/ref/Bugs.html | 4 ++-- html-test/ref/BundledPatterns.html | 4 ++-- html-test/ref/BundledPatterns2.html | 4 ++-- html-test/ref/ConstructorArgs.html | 2 +- html-test/ref/ConstructorPatternExport.html | 4 ++-- html-test/ref/DeprecatedClass.html | 4 ++-- html-test/ref/DeprecatedData.html | 4 ++-- html-test/ref/DeprecatedFunction.html | 4 ++-- html-test/ref/DeprecatedFunction2.html | 4 ++-- html-test/ref/DeprecatedFunction3.html | 4 ++-- html-test/ref/DeprecatedModule.html | 4 ++-- html-test/ref/DeprecatedModule2.html | 4 ++-- html-test/ref/DeprecatedNewtype.html | 4 ++-- html-test/ref/DeprecatedReExport.html | 2 +- html-test/ref/DeprecatedRecord.html | 4 ++-- html-test/ref/DeprecatedTypeFamily.html | 4 ++-- html-test/ref/DeprecatedTypeSynonym.html | 4 ++-- html-test/ref/DuplicateRecordFields.html | 4 ++-- html-test/ref/Examples.html | 4 ++-- html-test/ref/Extensions.html | 4 ++-- html-test/ref/FunArgs.html | 2 +- html-test/ref/GADTRecords.html | 4 ++-- html-test/ref/GadtConstructorArgs.html | 2 +- html-test/ref/Hash.html | 2 +- html-test/ref/HiddenInstances.html | 2 +- html-test/ref/HiddenInstancesB.html | 2 +- html-test/ref/Hyperlinks.html | 4 ++-- html-test/ref/ImplicitParams.html | 4 ++-- html-test/ref/Instances.html | 2 +- html-test/ref/Math.html | 4 ++-- html-test/ref/Minimal.html | 4 ++-- html-test/ref/ModuleWithWarning.html | 4 ++-- html-test/ref/NamedDoc.html | 4 ++-- html-test/ref/Nesting.html | 4 ++-- html-test/ref/NoLayout.html | 4 ++-- html-test/ref/NonGreedy.html | 4 ++-- html-test/ref/Operators.html | 4 ++-- html-test/ref/OrphanInstances.html | 2 +- html-test/ref/OrphanInstancesClass.html | 2 +- html-test/ref/OrphanInstancesType.html | 2 +- html-test/ref/PR643.html | 4 ++-- html-test/ref/PR643_1.html | 4 ++-- html-test/ref/PatternSyns.html | 4 ++-- html-test/ref/PromotedTypes.html | 4 ++-- html-test/ref/Properties.html | 4 ++-- html-test/ref/PruneWithWarning.html | 4 ++-- html-test/ref/QuantifiedConstraints.html | 2 +- html-test/ref/QuasiExpr.html | 2 +- html-test/ref/QuasiQuote.html | 4 ++-- html-test/ref/SpuriousSuperclassConstraints.html | 2 +- html-test/ref/TH.html | 4 ++-- html-test/ref/TH2.html | 4 ++-- html-test/ref/Table.html | 2 +- html-test/ref/Test.html | 2 +- html-test/ref/Threaded.html | 4 ++-- html-test/ref/Threaded_TH.html | 4 ++-- html-test/ref/Ticket112.html | 4 ++-- html-test/ref/Ticket61.html | 4 ++-- html-test/ref/Ticket75.html | 4 ++-- html-test/ref/TitledPicture.html | 4 ++-- html-test/ref/TypeFamilies.html | 2 +- html-test/ref/TypeFamilies2.html | 2 +- html-test/ref/TypeFamilies3.html | 2 +- html-test/ref/TypeOperators.html | 4 ++-- html-test/ref/Unicode.html | 4 ++-- html-test/ref/Unicode2.html | 2 +- html-test/ref/Visible.html | 4 ++-- 100 files changed, 170 insertions(+), 170 deletions(-) (limited to 'html-test') diff --git a/html-test/ref/A.html b/html-test/ref/A.html index 567e23f2..53a26042 100644 --- a/html-test/ref/A.html +++ b/html-test/ref/A.html @@ -4,7 +4,7 @@ />A
Safe HaskellSafe

Bug973

Synopsis

Documentation

showRead #

Arguments

:: forall a b. (Show a, Read b)
=> a

this gets turned into a string...

-> b

...from which this is read

showRead' #

Arguments

:: forall b a. (Show a, Read b)
=> a

this gets turned into a string...

-> b

...from which this is read

Same as showRead, but with type variable order flipped

\ No newline at end of file diff --git a/html-test/ref/FunArgs.html b/html-test/ref/FunArgs.html index bb54fa27..b40aa97c 100644 --- a/html-test/ref/FunArgs.html +++ b/html-test/ref/FunArgs.html @@ -58,7 +58,9 @@ >
:: :: forall a. Ord a:: forall a b c. a-> forall d. d=> forall c. a b c d proxy (a :: ()) b. proxy a
:: a

First argument

-> d

Result

:: forall (b :: ()). d ~ a (b :: ()) d. d ~ ()
=> a b c d

abcd

:: forall (a :: ()). proxy a

First argument

BlubType = Show x => x => BlubCtor x
  		• Show x => x => BlubCtor x
  • = C b => b => Ex1 b
  • | C a => a => Ex3 b
  		• C b => b => Ex1 bC a => a => Ex3 b a -- ^ this gets turned into a string... + -> b -- ^ ...from which this is read +showRead = read . show + +-- | Same as 'showRead', but with type variable order flipped +showRead' + :: forall b a. (Show a, Read b) + => a -- ^ this gets turned into a string... + -> b -- ^ ...from which this is read +showRead' = read . show -- cgit v1.2.3 From 53997f3db71d113bdad59548e3f16adfe90c112b Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 23 Jan 2019 11:46:46 -0800 Subject: Keep forall on H98 existential data constructors (#1003) The information about whether or not there is a source-level `forall` is already available on a `ConDecl` (as `con_forall`), so we should use it instead of always assuming `False`! Fixes #1002. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 ++-- html-test/ref/PatternSyns.html | 8 ++++++-- html-test/ref/Test.html | 24 ++++++++++++++++++------ 4 files changed, 27 insertions(+), 11 deletions(-) (limited to 'html-test') diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 40ea916f..a84e7e45 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -758,9 +758,9 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = decl = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt } -> let context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False header_ = ppConstrHdr forall_ tyVars context unicode in case det of -- Prefix constructor, e.g. 'Just a' diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 775e0c41..bc6e2c2b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -800,9 +800,9 @@ ppShortConstrParts summary dataInst con unicode qual = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt } -> let context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of @@ -873,9 +873,9 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) decl = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt } -> let context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html index bae4b0bd..7e10b755 100644 --- a/html-test/ref/PatternSyns.html +++ b/html-test/ref/PatternSyns.html @@ -104,7 +104,9 @@ >data BlubType = = forall x.Show x => BlubCtor
    forall x.Show x => BlubCtorEx a
    • = = forall b.C b => Ex1 b
    • | | forall b. Ex2 b
    • | | forall b.C a => Ex3 \ No newline at end of file +> -- cgit v1.2.3 From 384577e862171bdedc9311c9d17f7ad3a4a33456 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Fri, 17 May 2019 11:23:40 -0400 Subject: Fix #1063 with better parenthesization logic for contexts The only other change in html/hoogle/hyperlinker output for the boot libraries that this caused is a fix to some Hoogle output for implicit params. ``` $ diff -r _build/docs/ old_docs diff -r _build/docs/html/libraries/base/base.txt old_docs/html/libraries/base/base.txt 13296c13296 < assertError :: (?callStack :: CallStack) => Bool -> a -> a --- > assertError :: ?callStack :: CallStack => Bool -> a -> a ``` --- haddock-api/src/Haddock/GhcUtils.hs | 6 ++- html-test/ref/Bug1063.html | 100 ++++++++++++++++++++++++++++++++++++ html-test/src/Bug1063.hs | 9 ++++ 3 files changed, 113 insertions(+), 2 deletions(-) create mode 100644 html-test/ref/Bug1063.html create mode 100644 html-test/src/Bug1063.hs (limited to 'html-test') diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 29a52faf..5cc005cc 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -275,11 +275,13 @@ reparenTypePrec = go go p (HsKindSig x ty kind) = paren p PREC_SIG $ HsKindSig x (goL PREC_SIG ty) (goL PREC_SIG kind) go p (HsIParamTy x n ty) - = paren p PREC_CTX $ HsIParamTy x n (reparenLType ty) + = paren p PREC_SIG $ HsIParamTy x n (reparenLType ty) go p (HsForAllTy x tvs ty) = paren p PREC_CTX $ HsForAllTy x (map (fmap reparenTyVar) tvs) (reparenLType ty) go p (HsQualTy x ctxt ty) - = paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty) + = let p' [_] = PREC_CTX + p' _ = PREC_TOP -- parens will get added anyways later... + in paren p PREC_CTX $ HsQualTy x (fmap (\xs -> map (goL (p' xs)) xs) ctxt) (goL PREC_TOP ty) go p (HsFunTy x ty1 ty2) = paren p PREC_FUN $ HsFunTy x (goL PREC_FUN ty1) (goL PREC_TOP ty2) go p (HsAppTy x fun_ty arg_ty) diff --git a/html-test/ref/Bug1063.html b/html-test/ref/Bug1063.html new file mode 100644 index 00000000..a7555971 --- /dev/null +++ b/html-test/ref/Bug1063.html @@ -0,0 +1,100 @@ +Bug1063
      forall b.C b => Ex1
      forall b. Ex2 b
      forall b.C a => Ex3 Date: Fri, 25 Jan 2019 10:26:16 -0500 Subject: Fix #1004 with a pinch of dropForAlls --- haddock-api/src/Haddock/Convert.hs | 2 +- html-test/ref/Bug1004.html | 2072 ++++++++++++++++++++++++++++++++++++ html-test/src/Bug1004.hs | 3 + 3 files changed, 2076 insertions(+), 1 deletion(-) create mode 100644 html-test/ref/Bug1004.html create mode 100644 html-test/src/Bug1004.hs (limited to 'html-test') diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 6eee353b..7735ed0d 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -274,7 +274,7 @@ synifyTyCon coax tc -- which this function obtains. synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind GhcRn) synifyDataTyConReturnKind tc - = case splitFunTys (tyConKind tc) of + = case splitFunTys (dropForAlls (tyConKind tc)) of (_, ret_kind) | isLiftedTypeKind ret_kind -> Nothing -- Don't bother displaying :: * | otherwise -> Just (synifyKindSig ret_kind) diff --git a/html-test/ref/Bug1004.html b/html-test/ref/Bug1004.html new file mode 100644 index 00000000..9179e252 --- /dev/null +++ b/html-test/ref/Bug1004.html @@ -0,0 +1,2072 @@ +Bug1004
      Safe HaskellSafe

      Bug1004

      Synopsis

      Documentation

      data Product (f :: k -> Type) (g :: k -> Type) (a :: k) #

      Lifted product of functors.

      Constructors

      Pair (f a) (g a)

      Instances

      Instances details
      Generic1 (Product f g :: k -> Type)
      Instance details

      Defined in Data.Functor.Product

      Associated Types

      type Rep1 (Product f g) :: k -> Type #

      Methods

      from1 :: Product f g a -> Rep1 (Product f g) a #

      to1 :: Rep1 (Product f g) a -> Product f g a #

      (Monad f, Monad g) => Monad (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      (>>=) :: Product f g a -> (a -> Product f g b) -> Product f g b #

      (>>) :: Product f g a -> Product f g b -> Product f g b #

      return :: a -> Product f g a #

      fail :: String -> Product f g a #

      (Functor f, Functor g) => Functor (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      fmap :: (a -> b) -> Product f g a -> Product f g b #

      (<$) :: a -> Product f g b -> Product f g a #

      (MonadFix f, MonadFix g) => MonadFix (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      mfix :: (a -> Product f g a) -> Product f g a #

      (Applicative f, Applicative g) => Applicative (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      pure :: a -> Product f g a #

      (<*>) :: Product f g (a -> b) -> Product f g a -> Product f g b #

      liftA2 :: (a -> b -> c) -> Product f g a -> Product f g b -> Product f g c #

      (*>) :: Product f g a -> Product f g b -> Product f g b #

      (<*) :: Product f g a -> Product f g b -> Product f g a #

      (Foldable f, Foldable g) => Foldable (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      fold :: Monoid m => Product f g m -> m #

      foldMap :: Monoid m => (a -> m) -> Product f g a -> m #

      foldr :: (a -> b -> b) -> b -> Product f g a -> b #

      foldr' :: (a -> b -> b) -> b -> Product f g a -> b #

      foldl :: (b -> a -> b) -> b -> Product f g a -> b #

      foldl' :: (b -> a -> b) -> b -> Product f g a -> b #

      foldr1 :: (a -> a -> a) -> Product f g a -> a #

      foldl1 :: (a -> a -> a) -> Product f g a -> a #

      toList :: Product f g a -> [a] #

      null :: Product f g a -> Bool #

      length :: Product f g a -> Int #

      elem :: Eq a => a -> Product f g a -> Bool #

      maximum :: Ord a => Product f g a -> a #

      minimum :: Ord a => Product f g a -> a #

      sum :: Num a => Product f g a -> a #

      product :: Num a => Product f g a -> a #

      (Traversable f, Traversable g) => Traversable (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      traverse :: Applicative f0 => (a -> f0 b) -> Product f g a -> f0 (Product f g b) #

      sequenceA :: Applicative f0 => Product f g (f0 a) -> f0 (Product f g a) #

      mapM :: Monad m => (a -> m b) -> Product f g a -> m (Product f g b) #

      sequence :: Monad m => Product f g (m a) -> m (Product f g a) #

      (Eq1 f, Eq1 g) => Eq1 (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      liftEq :: (a -> b -> Bool) -> Product f g a -> Product f g b -> Bool #

      (Ord1 f, Ord1 g) => Ord1 (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      liftCompare :: (a -> b -> Ordering) -> Product f g a -> Product f g b -> Ordering #

      (Read1 f, Read1 g) => Read1 (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Product f g a) #

      liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [Product f g a] #

      liftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (Product f g a) #

      liftReadListPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec [Product f g a] #

      (Show1 f, Show1 g) => Show1 (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Product f g a -> ShowS #

      liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> [Product f g a] -> ShowS #

      (MonadZip f, MonadZip g) => MonadZip (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      mzip :: Product f g a -> Product f g b -> Product f g (a, b) #

      mzipWith :: (a -> b -> c) -> Product f g a -> Product f g b -> Product f g c #

      munzip :: Product f g (a, b) -> (Product f g a, Product f g b) #

      (Alternative f, Alternative g) => Alternative (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      empty :: Product f g a #

      (<|>) :: Product f g a -> Product f g a -> Product f g a #

      some :: Product f g a -> Product f g [a] #

      many :: Product f g a -> Product f g [a] #

      (MonadPlus f, MonadPlus g) => MonadPlus (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      mzero :: Product f g a #

      mplus :: Product f g a -> Product f g a -> Product f g a #

      (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      (==) :: Product f g a -> Product f g a -> Bool #

      (/=) :: Product f g a -> Product f g a -> Bool #

      (Typeable a, Typeable f, Typeable g, Typeable k, Data (f a), Data (g a)) => Data (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b) -> (forall g0. g0 -> c g0) -> Product f g a -> c (Product f g a) #

      gunfold :: (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c (Product f g a) #

      toConstr :: Product f g a -> Constr #

      dataTypeOf :: Product f g a -> DataType #

      dataCast1 :: Typeable t => (forall d. Data d => c (t d)) -> Maybe (c (Product f g a)) #

      dataCast2 :: Typeable t => (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Product f g a)) #

      gmapT :: (forall b. Data b => b -> b) -> Product f g a -> Product f g a #

      gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Product f g a -> r #

      gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Product f g a -> r #

      gmapQ :: (forall d. Data d => d -> u) -> Product f g a -> [u] #

      gmapQi :: Int -> (forall d. Data d => d -> u) -> Product f g a -> u #

      gmapM :: Monad m => (forall d. Data d => d -> m d) -> Product f g a -> m (Product f g a) #

      gmapMp :: MonadPlus m => (forall d. Data d => d -> m d) -> Product f g a -> m (Product f g a) #

      gmapMo :: MonadPlus m => (forall d. Data d => d -> m d) -> Product f g a -> m (Product f g a) #

      (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      compare :: Product f g a -> Product f g a -> Ordering #

      (<) :: Product f g a -> Product f g a -> Bool #

      (<=) :: Product f g a -> Product f g a -> Bool #

      (>) :: Product f g a -> Product f g a -> Bool #

      (>=) :: Product f g a -> Product f g a -> Bool #

      max :: Product f g a -> Product f g a -> Product f g a #

      min :: Product f g a -> Product f g a -> Product f g a #

      (Read1 f, Read1 g, Read a) => Read (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      readsPrec :: Int -> ReadS (Product f g a) #

      readList :: ReadS [Product f g a] #

      readPrec :: ReadPrec (Product f g a) #

      readListPrec :: ReadPrec [Product f g a] #

      (Show1 f, Show1 g, Show a) => Show (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      showsPrec :: Int -> Product f g a -> ShowS #

      show :: Product f g a -> String #

      showList :: [Product f g a] -> ShowS #

      Generic (Product f g a)
      Instance details

      Defined in Data.Functor.Product

      Associated Types

      type Rep (Product f g a) :: Type -> Type #

      Methods

      from :: Product f g a -> Rep (Product f g a) x #

      to :: Rep (Product f g a) x -> Product f g a #

      type Rep1 (Product f g :: k -> Type)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      type Rep1 (Product f g :: k -> Type) = D1 (MetaData "Product" "Data.Functor.Product" "base" False) (C1 (MetaCons "Pair" PrefixI False) (S1 (MetaSel (Nothing :: Maybe Symbol) NoSourceUnpackedness NoSourceStrictness DecidedLazy) (Rec1 f) :*: S1 (MetaSel (Nothing :: Maybe Symbol) NoSourceUnpackedness NoSourceStrictness DecidedLazy) (Rec1 g)))
      type Rep (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      type Rep (Product f g a) = D1 (MetaData "Product" "Data.Functor.Product" "base" False) (C1 (MetaCons "Pair" PrefixI False) (S1 (MetaSel (Nothing :: Maybe Symbol) NoSourceUnpackedness NoSourceStrictness DecidedLazy) (Rec0 (f a)) :*: S1 (MetaSel (Nothing :: Maybe Symbol) NoSourceUnpackedness NoSourceStrictness DecidedLazy) (Rec0 (g a))))
      \ No newline at end of file diff --git a/html-test/src/Bug1004.hs b/html-test/src/Bug1004.hs new file mode 100644 index 00000000..d789e77f --- /dev/null +++ b/html-test/src/Bug1004.hs @@ -0,0 +1,3 @@ +module Bug1004 (Product(..)) where + +import Data.Functor.Product -- cgit v1.2.3 From dd47029cb29c80b1ab4db520c9c2ce4dca37f833 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Thu, 19 Jul 2018 11:42:26 -0700 Subject: Support value/type namespaces on identifier links Identifier links can be prefixed with a 'v' or 't' to indicate the value or type namespace of the desired identifier. For example: -- | Some link to a value: v'Data.Functor.Identity' -- -- Some link to a type: t'Data.Functor.Identity' The default is still the type (with a warning about the ambiguity) --- doc/markup.rst | 10 ++ haddock-api/src/Haddock.hs | 3 +- haddock-api/src/Haddock/Interface/LexParseRn.hs | 55 ++++++-- .../src/Haddock/Interface/ParseModuleHeader.hs | 3 +- haddock-api/src/Haddock/Parser.hs | 13 +- haddock-api/src/Haddock/Types.hs | 6 + .../src/Documentation/Haddock/Parser.hs | 22 ++-- haddock-library/src/Documentation/Haddock/Types.hs | 10 ++ .../test/Documentation/Haddock/ParserSpec.hs | 6 + html-test/Main.hs | 2 +- html-test/ref/Bug253.html | 16 +-- html-test/ref/NamespacedIdentifiers.html | 146 +++++++++++++++++++++ html-test/src/NamespacedIdentifiers.hs | 13 ++ .../NamespacedIdentifier/NamespacedIdentifiers.tex | 41 ++++++ latex-test/ref/NamespacedIdentifier/haddock.sty | 57 ++++++++ latex-test/ref/NamespacedIdentifier/main.tex | 11 ++ .../NamespacedIdentifier/NamespacedIdentifier.hs | 13 ++ 17 files changed, 388 insertions(+), 39 deletions(-) create mode 100644 html-test/ref/NamespacedIdentifiers.html create mode 100644 html-test/src/NamespacedIdentifiers.hs create mode 100644 latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex create mode 100644 latex-test/ref/NamespacedIdentifier/haddock.sty create mode 100644 latex-test/ref/NamespacedIdentifier/main.tex create mode 100644 latex-test/src/NamespacedIdentifier/NamespacedIdentifier.hs (limited to 'html-test') diff --git a/doc/markup.rst b/doc/markup.rst index 9fb0209a..48a6f4ad 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -913,6 +913,16 @@ If ``M.T`` is not otherwise in scope, then Haddock will simply emit a link pointing to the entity ``T`` exported from module ``M`` (without checking to see whether either ``M`` or ``M.T`` exist). +Since values and types live in different namespaces in Haskell, it is +possible for a reference such as ``'X'`` to be ambiguous. In such a case, +Haddock defaults to pointing to the type. The ambiguity can be overcome by explicitly specifying a namespace, by way of a ``v`` (for value) or ``t`` +(for type) immediately before the link: :: + + -- | An implicit reference to 'X', the type constructor + -- An explicit reference to v'X', the data constructor + -- An explicit reference to t'X', the type constructor + data X = X + To make life easier for documentation writers, a quoted identifier is only interpreted as such if the quotes surround a lexically valid Haskell identifier. This means, for example, that it normally isn't diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 358e5c3a..1378c173 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -42,6 +42,7 @@ import Haddock.Utils import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir) import Control.Monad hiding (forM_) +import Data.Bifunctor (second) import Data.Foldable (forM_, foldl') import Data.Traversable (for) import Data.List (isPrefixOf) @@ -662,7 +663,7 @@ getPrologue dflags flags = h <- openFile filename ReadMode hSetEncoding h utf8 str <- hGetContents h -- semi-closes the handle - return . Just $! parseParas dflags Nothing str + return . Just $! second rdrName $ parseParas dflags Nothing str _ -> throwE "multiple -p/--prologue options" diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 59ad4fdf..66083cf5 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -34,8 +34,8 @@ import Haddock.Types import Name import Outputable ( showPpr, showSDoc ) import RdrName +import RdrHsSyn (setRdrNameSpace) import EnumSet -import RnEnv (dataTcOccs) processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name)) @@ -89,24 +89,37 @@ processModuleHeader dflags pkgName gre safety mayStr = do -- fallbacks in case we can't locate the identifiers. -- -- See the comments in the source for implementation commentary. -rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name) +rename :: DynFlags -> GlobalRdrEnv -> Doc NsRdrName -> ErrMsgM (Doc Name) rename dflags gre = rn where rn d = case d of DocAppend a b -> DocAppend <$> rn a <*> rn b DocParagraph doc -> DocParagraph <$> rn doc - DocIdentifier x -> do + DocIdentifier (NsRdrName ns x) -> do + let occ = rdrNameOcc x + isValueName = isDataOcc occ || isVarOcc occ + + let valueNsChoices | isValueName = [x] + | otherwise = [] -- is this ever possible? + typeNsChoices | isValueName = [setRdrNameSpace x tcName] + | otherwise = [x] + -- Generate the choices for the possible kind of thing this - -- is. - let choices = dataTcOccs x + -- is. We narrow down the possibilities with the namespace (if + -- there is one). + let choices = case ns of + Value -> valueNsChoices + Type -> typeNsChoices + None -> valueNsChoices ++ typeNsChoices -- Lookup any GlobalRdrElts that match the choices. case concatMap (\c -> lookupGRE_RdrName c gre) choices of -- We found no names in the env so we start guessing. [] -> case choices of - -- This shouldn't happen as 'dataTcOccs' always returns at least its input. - [] -> pure (DocMonospaced (DocString (showPpr dflags x))) + -- The only way this can happen is if a value namespace was + -- specified on something that cannot be a value. + [] -> invalidValue dflags x -- There was nothing in the environment so we need to -- pick some default from what's available to us. We @@ -116,7 +129,7 @@ rename dflags gre = rn -- type constructor names (such as in #253). So now we -- only get type constructor links if they are actually -- in scope. - a:_ -> outOfScope dflags a + a:_ -> outOfScope dflags ns a -- There is only one name in the environment that matches so -- use it. @@ -155,17 +168,23 @@ rename dflags gre = rn -- users shouldn't rely on this doing the right thing. See tickets -- #253 and #375 on the confusion this causes depending on which -- default we pick in 'rename'. -outOfScope :: DynFlags -> RdrName -> ErrMsgM (Doc a) -outOfScope dflags x = +outOfScope :: DynFlags -> Namespace -> RdrName -> ErrMsgM (Doc a) +outOfScope dflags ns x = case x of Unqual occ -> warnAndMonospace occ Qual mdl occ -> pure (DocIdentifierUnchecked (mdl, occ)) Orig _ occ -> warnAndMonospace occ Exact name -> warnAndMonospace name -- Shouldn't happen since x is out of scope where + prefix = case ns of + Value -> "the value " + Type -> "the type " + None -> "" + warnAndMonospace a = do - tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope.\n" ++ - " If you qualify the identifier, haddock can try to link it anyway."] + tell ["Warning: " ++ prefix ++ "'" ++ showPpr dflags a ++ "' is out of scope.\n" ++ + " If you qualify the identifier, haddock can try to link it\n" ++ + " it anyway."] pure (monospaced a) monospaced a = DocMonospaced (DocString (showPpr dflags a)) @@ -184,7 +203,7 @@ ambiguous dflags x gres = do msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++ concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++ " You may be able to disambiguate the identifier by qualifying it or\n" ++ - " by hiding some imports.\n" ++ + " by specifying the type/value namespace explicitly.\n" ++ " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt -- TODO: Once we have a syntax for namespace qualification (#667) we may also -- want to emit a warning when an identifier is a data constructor for a type @@ -198,3 +217,13 @@ ambiguous dflags x gres = do isLocalName _ = False x_str = '\'' : showPpr dflags x ++ "'" defnLoc = showSDoc dflags . pprNameDefnLoc + +-- | Handle value-namespaced names that cannot be for values. +-- +-- Emits a warning that the value-namespace is invalid on a non-value identifier. +invalidValue :: DynFlags -> RdrName -> ErrMsgM (Doc a) +invalidValue dflags x = do + tell ["Warning: '" ++ showPpr dflags x ++ "' cannot be value, yet it is\n" ++ + " namespaced as such. Did you mean to specify a type namespace\n" ++ + " instead?"] + pure (DocMonospaced (DocString (showPpr dflags x))) diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index 050901b6..802ea773 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -16,7 +16,6 @@ import Data.Char import DynFlags import Haddock.Parser import Haddock.Types -import RdrName -- ----------------------------------------------------------------------------- -- Parsing module headers @@ -24,7 +23,7 @@ import RdrName -- NB. The headers must be given in the order Module, Description, -- Copyright, License, Maintainer, Stability, Portability, except that -- any or all may be omitted. -parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName) +parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName) parseModuleHeader dflags pkgName str0 = let getKey :: String -> String -> (Maybe String,String) diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index e31ea6a8..8b7dda7c 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -15,26 +15,27 @@ module Haddock.Parser ( parseParas import qualified Documentation.Haddock.Parser as P import Documentation.Haddock.Types +import Haddock.Types (NsRdrName(..)) import DynFlags ( DynFlags ) import FastString ( fsLit ) import Lexer ( mkPState, unP, ParseResult(POk) ) import Parser ( parseIdentifier ) import RdrName ( RdrName ) -import SrcLoc ( mkRealSrcLoc, unLoc ) +import SrcLoc ( mkRealSrcLoc, GenLocated(..) ) import StringBuffer ( stringToStringBuffer ) -parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod RdrName +parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod NsRdrName parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p -parseString :: DynFlags -> String -> DocH mod RdrName +parseString :: DynFlags -> String -> DocH mod NsRdrName parseString d = P.overIdentifier (parseIdent d) . P.parseString -parseIdent :: DynFlags -> String -> Maybe RdrName -parseIdent dflags str0 = +parseIdent :: DynFlags -> Namespace -> String -> Maybe NsRdrName +parseIdent dflags ns str0 = let buffer = stringToStringBuffer str0 realSrcLc = mkRealSrcLoc (fsLit "") 0 0 pstate = mkPState dflags buffer realSrcLc in case unP parseIdentifier pstate of - POk _ name -> Just (unLoc name) + POk _ (L _ name) -> Just (NsRdrName ns name) _ -> Nothing diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index a4ef5f82..e8da4120 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -284,6 +284,12 @@ noDocForDecl = (Documentation Nothing Nothing, mempty) -- | Type of environment used to cross-reference identifiers in the syntax. type LinkEnv = Map Name Module +-- | An 'RdrName' tagged with some type/value namespace information. +data NsRdrName = NsRdrName + { namespace :: !Namespace + , rdrName :: !RdrName + } + -- | Extends 'Name' with cross-reference information. data DocName = Documented Name Module diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 82d65a0a..e9b1c496 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -28,6 +28,7 @@ import Control.Applicative import Control.Arrow (first) import Control.Monad import Data.Char (chr, isUpper, isAlpha, isAlphaNum, isSpace) +import Data.Foldable (asum) import Data.List (intercalate, unfoldr, elemIndex) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid @@ -75,24 +76,24 @@ isSymbolChar c = not (isPuncChar c) && case generalCategory c of #endif -- | Identifier string surrounded with opening and closing quotes/backticks. -type Identifier = (Char, String, Char) +data Identifier = Identifier !Namespace !Char String !Char -- | Drops the quotes/backticks around all identifiers, as if they -- were valid but still 'String's. toRegular :: DocH mod Identifier -> DocH mod String -toRegular = fmap (\(_, x, _) -> x) +toRegular = fmap (\(Identifier _ _ x _) -> x) -- | Maps over 'DocIdentifier's over 'String' with potentially failing -- conversion using user-supplied function. If the conversion fails, -- the identifier is deemed to not be valid and is treated as a -- regular string. -overIdentifier :: (String -> Maybe a) +overIdentifier :: (Namespace -> String -> Maybe a) -> DocH mod Identifier -> DocH mod a overIdentifier f d = g d where - g (DocIdentifier (o, x, e)) = case f x of - Nothing -> DocString $ o : x ++ [e] + g (DocIdentifier (Identifier ns o x e)) = case f ns x of + Nothing -> DocString $ renderNs ns ++ [o] ++ x ++ [e] Just x' -> DocIdentifier x' g DocEmpty = DocEmpty g (DocAppend x x') = DocAppend (g x) (g x') @@ -314,7 +315,8 @@ markdownImage :: Parser (DocH mod Identifier) markdownImage = DocPic . fromHyperlink <$> ("!" *> linkParser) where fromHyperlink (Hyperlink u l) = Picture u (fmap (markup stringMarkup) l) - stringMarkup = plainMarkup (const "") (\(l,c,r) -> [l] <> c <> [r]) + stringMarkup = plainMarkup (const "") renderIdent + renderIdent (Identifier ns l c r) = renderNs ns <> [l] <> c <> [r] -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier) @@ -857,9 +859,13 @@ parseValid = p some -- 'String' from the string it deems valid. identifier :: Parser (DocH mod Identifier) identifier = do + ns <- asum [ Value <$ Parsec.char 'v' + , Type <$ Parsec.char 't' + , pure None + ] o <- idDelim vid <- parseValid e <- idDelim - return $ DocIdentifier (o, vid, e) + return $ DocIdentifier (Identifier ns o vid e) where - idDelim = Parsec.satisfy (\c -> c == '\'' || c == '`') + idDelim = Parsec.oneOf "'`" diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index f8f7d353..ba2f873c 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -203,6 +203,16 @@ instance Bitraversable DocH where bitraverse f g (DocTable (Table header body)) = (\h b -> DocTable (Table h b)) <$> traverse (traverse (bitraverse f g)) header <*> traverse (traverse (bitraverse f g)) body #endif +-- | The namespace qualification for an identifier. +data Namespace = Value | Type | None deriving (Eq, Ord, Enum, Show) + +-- | Render the a namespace into the same format it was initially parsed. +renderNs :: Namespace -> String +renderNs Value = "v" +renderNs Type = "t" +renderNs None = "" + + -- | 'DocMarkupH' is a set of instructions for marking up documentation. -- In fact, it's really just a mapping from 'Doc' to some other -- type [a], where [a] is usually the type of the output (HTML, say). diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index 6269184a..e186a5cf 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -132,6 +132,12 @@ spec = do it "can parse an identifier that starts with an underscore" $ do "'_x'" `shouldParseTo` DocIdentifier "_x" + it "can parse value-namespaced identifiers" $ do + "v'foo'" `shouldParseTo` DocIdentifier "foo" + + it "can parse type-namespaced identifiers" $ do + "t'foo'" `shouldParseTo` DocIdentifier "foo" + context "when parsing operators" $ do it "can parse an operator enclosed within single quotes" $ do "'.='" `shouldParseTo` DocIdentifier ".=" diff --git a/html-test/Main.hs b/html-test/Main.hs index d65a5087..26eefe4a 100755 --- a/html-test/Main.hs +++ b/html-test/Main.hs @@ -45,7 +45,7 @@ stripIfRequired mdl = -- | List of modules in which we don't 'stripLinks' preserveLinksModules :: [String] -preserveLinksModules = ["Bug253"] +preserveLinksModules = ["Bug253.html", "NamespacedIdentifiers.html"] ingoredTests :: [FilePath] ingoredTests = diff --git a/html-test/ref/Bug253.html b/html-test/ref/Bug253.html index a1c0f905..a01c9578 100644 --- a/html-test/ref/Bug253.html +++ b/html-test/ref/Bug253.html @@ -4,9 +4,9 @@ />Bug253
      Safe HaskellSafe

      NamespacedIdentifiers

      Synopsis

      Documentation

      data Foo #

      A link to:

      • the type Bar
      • the constructor Bar
      • the unimported but qualified type A
      • the unimported but qualified value A

      Constructors

      Bar 

      data Bar #

      A link to the value Foo (which shouldn't exist).

      diff --git a/html-test/src/NamespacedIdentifiers.hs b/html-test/src/NamespacedIdentifiers.hs new file mode 100644 index 00000000..6f59d247 --- /dev/null +++ b/html-test/src/NamespacedIdentifiers.hs @@ -0,0 +1,13 @@ +module NamespacedIdentifiers where + +-- | A link to: +-- +-- * the type t'Bar' +-- * the constructor v'Bar' +-- * the unimported but qualified type t'A.A' +-- * the unimported but qualified value v'A.A' +-- +data Foo = Bar + +-- | A link to the value v'Foo' (which shouldn't exist). +data Bar diff --git a/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex b/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex new file mode 100644 index 00000000..f39bd0ec --- /dev/null +++ b/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex @@ -0,0 +1,41 @@ +\haddockmoduleheading{NamespacedIdentifiers} +\label{module:NamespacedIdentifiers} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module NamespacedIdentifiers ( + Foo(Bar), Bar + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ Foo +\end{tabular}]\haddockbegindoc +A link to:\par +\begin{itemize} +\item +the type \haddockid{Bar}\par + +\item +the constructor \haddockid{Bar}\par + +\item +the unimported but qualified type \haddockid{A}\par + +\item +the unimported but qualified value \haddockid{A}\par + +\end{itemize} + +\enspace \emph{Constructors}\par +\haddockbeginconstrs +\haddockdecltt{=} & \haddockdecltt{Bar} & \\ +\end{tabulary}\par +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ Bar +\end{tabular}]\haddockbegindoc +A link to the value \haddocktt{Foo} (which shouldn't exist).\par + +\end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/NamespacedIdentifier/haddock.sty b/latex-test/ref/NamespacedIdentifier/haddock.sty new file mode 100644 index 00000000..6e031a98 --- /dev/null +++ b/latex-test/ref/NamespacedIdentifier/haddock.sty @@ -0,0 +1,57 @@ +% Default Haddock style definitions. To use your own style, invoke +% Haddock with the option --latex-style=mystyle. + +\usepackage{tabulary} % see below + +% make hyperlinks in the PDF, and add an expandabale index +\usepackage[pdftex,bookmarks=true]{hyperref} + +\newenvironment{haddocktitle} + {\begin{center}\bgroup\large\bfseries} + {\egroup\end{center}} +\newenvironment{haddockprologue}{\vspace{1in}}{} + +\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} + +\newcommand{\haddockbeginheader}{\hrulefill} +\newcommand{\haddockendheader}{\noindent\hrulefill} + +% a little gap before the ``Methods'' header +\newcommand{\haddockpremethods}{\vspace{2ex}} + +% inserted before \\begin{verbatim} +\newcommand{\haddockverb}{\small} + +% an identifier: add an index entry +\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} + +% The tabulary environment lets us have a column that takes up ``the +% rest of the space''. Unfortunately it doesn't allow +% the \end{tabulary} to be in the expansion of a macro, it must appear +% literally in the document text, so Haddock inserts +% the \end{tabulary} itself. +\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} +\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} + +\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} +\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} + +\makeatletter +\newenvironment{haddockdesc} + {\list{}{\labelwidth\z@ \itemindent-\leftmargin + \let\makelabel\haddocklabel}} + {\endlist} +\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} +\makeatother + +% after a declaration, start a new line for the documentation. +% Otherwise, the documentation starts right after the declaration, +% because we're using the list environment and the declaration is the +% ``label''. I tried making this newline part of the label, but +% couldn't get that to work reliably (the space seemed to stretch +% sometimes). +\newcommand{\haddockbegindoc}{\hfill\\[1ex]} + +% spacing between paragraphs and no \parindent looks better +\parskip=10pt plus2pt minus2pt +\setlength{\parindent}{0cm} diff --git a/latex-test/ref/NamespacedIdentifier/main.tex b/latex-test/ref/NamespacedIdentifier/main.tex new file mode 100644 index 00000000..75493e12 --- /dev/null +++ b/latex-test/ref/NamespacedIdentifier/main.tex @@ -0,0 +1,11 @@ +\documentclass{book} +\usepackage{haddock} +\begin{document} +\begin{titlepage} +\begin{haddocktitle} + +\end{haddocktitle} +\end{titlepage} +\tableofcontents +\input{NamespacedIdentifiers} +\end{document} \ No newline at end of file diff --git a/latex-test/src/NamespacedIdentifier/NamespacedIdentifier.hs b/latex-test/src/NamespacedIdentifier/NamespacedIdentifier.hs new file mode 100644 index 00000000..6f59d247 --- /dev/null +++ b/latex-test/src/NamespacedIdentifier/NamespacedIdentifier.hs @@ -0,0 +1,13 @@ +module NamespacedIdentifiers where + +-- | A link to: +-- +-- * the type t'Bar' +-- * the constructor v'Bar' +-- * the unimported but qualified type t'A.A' +-- * the unimported but qualified value v'A.A' +-- +data Foo = Bar + +-- | A link to the value v'Foo' (which shouldn't exist). +data Bar -- cgit v1.2.3 From a5199600c39d25d7b71dcb2328000c1c49ad95a2 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 6 Feb 2019 01:01:41 -0800 Subject: Better identifier parsing * '(<|>)' and '`elem`' now get parsed and rendered properly as links * 'DbModule'/'DbUnitId' now properly get split apart into two links * tuple names now get parsed properly * some more small niceties... The identifier parsing code is more precise and more efficient (although to be fair: it is also longer and in its own module). On the rendering side, we need to pipe through information about backticks/parens/neither all the way through from renaming to the backends. In terms of impact: a total of 35 modules in the entirety of the bootlib + ghc lib docs change. The only "regression" is things like '\0'. These should be changed to @\\0@ (the path by which this previously worked seems accidental). --- doc/markup.rst | 9 +- haddock-api/src/Haddock.hs | 2 +- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 19 +- .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 16 +- haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 28 +- haddock-api/src/Haddock/Interface/Json.hs | 5 +- haddock-api/src/Haddock/Interface/LexParseRn.hs | 58 +++-- haddock-api/src/Haddock/Interface/Rename.hs | 4 +- haddock-api/src/Haddock/InterfaceFile.hs | 27 +- haddock-api/src/Haddock/Parser.hs | 19 +- haddock-api/src/Haddock/Types.hs | 28 +- haddock-library/haddock-library.cabal | 2 + .../src/Documentation/Haddock/Parser.hs | 63 +---- .../src/Documentation/Haddock/Parser/Identifier.hs | 186 ++++++++++++++ .../src/Documentation/Haddock/Parser/Monad.hs | 13 +- .../test/Documentation/Haddock/ParserSpec.hs | 9 +- haddock.cabal | 1 + html-test/ref/Identifiers.html | 286 +++++++++++++++++++++ html-test/ref/Test.html | 2 +- html-test/src/Identifiers.hs | 35 +++ 21 files changed, 679 insertions(+), 135 deletions(-) create mode 100644 haddock-library/src/Documentation/Haddock/Parser/Identifier.hs create mode 100644 html-test/ref/Identifiers.html create mode 100644 html-test/src/Identifiers.hs (limited to 'html-test') diff --git a/doc/markup.rst b/doc/markup.rst index 48a6f4ad..56238855 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -932,14 +932,9 @@ necessary to escape the single quote when used as an apostrophe: :: Nothing special is needed to hyperlink identifiers which contain apostrophes themselves: to hyperlink ``foo'`` one would simply type -``'foo''``. Hyperlinking operators works in exactly the same way. +``'foo''``. Hyperlinking operators works in exactly the same way. :: -Note that it is not possible to directly hyperlink an identifier in infix -form or an operator in prefix form. The next best thing to do is to wrap -the whole identifier in monospaced text and put the parentheses/backticks -outside of the identifier, but inside the link: :: - - -- | A prefix operator @('++')@ and an infix identifier @\``elem`\`@. + -- | A prefix operator @'(++)'@ and an infix identifier @'`elem`'@. Emphasis, Bold and Monospaced Text ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 1378c173..3e0332b5 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -663,7 +663,7 @@ getPrologue dflags flags = h <- openFile filename ReadMode hSetEncoding h utf8 str <- hGetContents h -- semi-closes the handle - return . Just $! second rdrName $ parseParas dflags Nothing str + return . Just $! second (fmap rdrName) $ parseParas dflags Nothing str _ -> throwE "multiple -p/--prologue options" diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 9e3186e5..f581c01a 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -334,7 +334,7 @@ markupTag dflags = Markup { markupString = str, markupAppend = (++), markupIdentifier = box (TagInline "a") . str . out dflags, - markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd, + markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd), markupModule = box (TagInline "a") . str, markupWarning = box (TagInline "i"), markupEmphasis = box (TagInline "i"), diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index d0752506..85769b13 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1106,8 +1106,8 @@ ppSymName name | otherwise = ppName name -ppVerbOccName :: OccName -> LaTeX -ppVerbOccName = text . latexFilter . occNameString +ppVerbOccName :: Wrap OccName -> LaTeX +ppVerbOccName = text . latexFilter . showWrapped occNameString ppIPName :: HsIPName -> LaTeX ppIPName = text . ('?':) . unpackFS . hsIPNameFS @@ -1115,13 +1115,12 @@ ppIPName = text . ('?':) . unpackFS . hsIPNameFS ppOccName :: OccName -> LaTeX ppOccName = text . occNameString +ppVerbDocName :: Wrap DocName -> LaTeX +ppVerbDocName = text . latexFilter . showWrapped (occNameString . nameOccName . getName) -ppVerbDocName :: DocName -> LaTeX -ppVerbDocName = ppVerbOccName . nameOccName . getName - -ppVerbRdrName :: RdrName -> LaTeX -ppVerbRdrName = ppVerbOccName . rdrNameOcc +ppVerbRdrName :: Wrap RdrName -> LaTeX +ppVerbRdrName = text . latexFilter . showWrapped (occNameString . rdrNameOcc) ppDocName :: DocName -> LaTeX @@ -1182,7 +1181,7 @@ parLatexMarkup ppId = Markup { markupString = \s v -> text (fixString v s), markupAppend = \l r v -> l v <> r v, markupIdentifier = markupId ppId, - markupIdentifierUnchecked = markupId (ppVerbOccName . snd), + markupIdentifierUnchecked = markupId (ppVerbOccName . fmap snd), markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), markupWarning = \p v -> emph (p v), markupEmphasis = \p v -> emph (p v), @@ -1239,11 +1238,11 @@ parLatexMarkup ppId = Markup { where theid = ppId_ id -latexMarkup :: DocMarkup DocName (StringContext -> LaTeX) +latexMarkup :: DocMarkup (Wrap DocName) (StringContext -> LaTeX) latexMarkup = parLatexMarkup ppVerbDocName -rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX) +rdrLatexMarkup :: DocMarkup (Wrap RdrName) (StringContext -> LaTeX) rdrLatexMarkup = parLatexMarkup ppVerbRdrName diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 09aabc0c..1901cf05 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -171,12 +171,12 @@ flatten x = [x] -- extract/append the underlying 'Doc' and convert it to 'Html'. For -- 'CollapsingHeader', we attach extra info to the generated 'Html' -- that allows us to expand/collapse the content. -hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (ModuleName, OccName) id -> Html +hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (Wrap (ModuleName, OccName)) id -> Html hackMarkup fmt' currPkg h' = let (html, ms) = hackMarkup' fmt' h' in html +++ renderMeta fmt' currPkg (metaConcat ms) where - hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id + hackMarkup' :: DocMarkup id Html -> Hack (Wrap (ModuleName, OccName)) id -> (Html, [Meta]) hackMarkup' fmt h = case h of UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) @@ -206,7 +206,7 @@ renderMeta _ _ _ = noHtml -- | Goes through 'hackMarkup' to generate the 'Html' rather than -- skipping straight to 'markup': this allows us to employ XHtml -- specific hacks to the tree first. -markupHacked :: DocMarkup id Html +markupHacked :: DocMarkup (Wrap id) Html -> Maybe Package -- this package -> Maybe String -> MDoc id @@ -220,7 +220,7 @@ docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html docToHtml n pkg qual = markupHacked fmt pkg n . cleanup - where fmt = parHtmlMarkup qual True (ppDocName qual Raw) + where fmt = parHtmlMarkup qual True (ppWrappedDocName qual Raw) -- | Same as 'docToHtml' but it doesn't insert the 'anchor' element -- in links. This is used to generate the Contents box elements. @@ -228,16 +228,16 @@ docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack' -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup - where fmt = parHtmlMarkup qual False (ppDocName qual Raw) + where fmt = parHtmlMarkup qual False (ppWrappedDocName qual Raw) origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup - where fmt = parHtmlMarkup qual True (const $ ppName Raw) + where fmt = parHtmlMarkup qual True (const (ppWrappedName Raw)) rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup - where fmt = parHtmlMarkup qual True (const ppRdrName) + where fmt = parHtmlMarkup qual True (const (ppRdrName . unwrap)) docElement :: (Html -> Html) -> Html -> Html @@ -273,7 +273,7 @@ cleanup = overDoc (markup fmtUnParagraphLists) unParagraph (DocParagraph d) = d unParagraph doc = doc - fmtUnParagraphLists :: DocMarkup a (Doc a) + fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a) fmtUnParagraphLists = idMarkup { markupUnorderedList = DocUnorderedList . map unParagraph, markupOrderedList = DocOrderedList . map unParagraph diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs index 574045e0..6a047747 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -13,7 +13,8 @@ module Haddock.Backends.Xhtml.Names ( ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, ppBinder, ppBinderInfix, ppBinder', - ppModule, ppModuleRef, ppIPName, linkId, Notation(..) + ppModule, ppModuleRef, ppIPName, linkId, Notation(..), + ppWrappedDocName, ppWrappedName, ) where @@ -24,7 +25,7 @@ import Haddock.Utils import Text.XHtml hiding ( name, p, quote ) import qualified Data.Map as M -import qualified Data.List as List +import Data.List ( stripPrefix ) import GHC hiding (LexicalFixity(..)) import Name @@ -49,9 +50,11 @@ ppIPName :: HsIPName -> Html ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS -ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html -ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName - +ppUncheckedLink :: Qualification -> Wrap (ModuleName, OccName) -> Html +ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml + where + (mdl, occ) = unwrap x + occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName -- The Bool indicates if it is to be rendered in infix notation ppLDocName :: Qualification -> Notation -> Located DocName -> Html @@ -68,6 +71,19 @@ ppDocName qual notation insertAnchors docName = ppQualifyName qual notation name (nameModule name) | otherwise -> ppName notation name + +ppWrappedDocName :: Qualification -> Notation -> Bool -> Wrap DocName -> Html +ppWrappedDocName qual notation insertAnchors docName = case docName of + Unadorned n -> ppDocName qual notation insertAnchors n + Parenthesized n -> ppDocName qual Prefix insertAnchors n + Backticked n -> ppDocName qual Infix insertAnchors n + +ppWrappedName :: Notation -> Wrap Name -> Html +ppWrappedName notation docName = case docName of + Unadorned n -> ppName notation n + Parenthesized n -> ppName Prefix n + Backticked n -> ppName Infix n + -- | Render a name depending on the selected qualification mode ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html ppQualifyName qual notation name mdl = @@ -79,7 +95,7 @@ ppQualifyName qual notation name mdl = then ppName notation name else ppFullQualName notation mdl name RelativeQual localmdl -> - case List.stripPrefix (moduleString localmdl) (moduleString mdl) of + case stripPrefix (moduleString localmdl) (moduleString mdl) of -- local, A.x -> x Just [] -> ppName notation name -- sub-module, A.B.x -> B.x diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs index 636d3e19..a9834fa0 100644 --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -62,7 +62,10 @@ jsonMDoc MetaDoc{..} = ] jsonDoc :: Doc Name -> JsonDoc -jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc)) +jsonDoc doc = jsonString (show (bimap showModName showName doc)) + where + showModName = showWrapped (moduleNameString . fst) + showName = showWrapped nameStableString jsonModule :: Module -> JsonDoc jsonModule = JSString . moduleStableString diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 66083cf5..faf23728 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -22,6 +22,7 @@ module Haddock.Interface.LexParseRn import Avail import Control.Arrow import Control.Monad +import Data.Functor (($>)) import Data.List import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) @@ -95,8 +96,9 @@ rename dflags gre = rn rn d = case d of DocAppend a b -> DocAppend <$> rn a <*> rn b DocParagraph doc -> DocParagraph <$> rn doc - DocIdentifier (NsRdrName ns x) -> do - let occ = rdrNameOcc x + DocIdentifier i -> do + let NsRdrName ns x = unwrap i + occ = rdrNameOcc x isValueName = isDataOcc occ || isVarOcc occ let valueNsChoices | isValueName = [x] @@ -119,7 +121,7 @@ rename dflags gre = rn case choices of -- The only way this can happen is if a value namespace was -- specified on something that cannot be a value. - [] -> invalidValue dflags x + [] -> invalidValue dflags i -- There was nothing in the environment so we need to -- pick some default from what's available to us. We @@ -129,14 +131,14 @@ rename dflags gre = rn -- type constructor names (such as in #253). So now we -- only get type constructor links if they are actually -- in scope. - a:_ -> outOfScope dflags ns a + a:_ -> outOfScope dflags ns (i $> a) -- There is only one name in the environment that matches so -- use it. - [a] -> pure (DocIdentifier (gre_name a)) + [a] -> pure (DocIdentifier (i $> gre_name a)) -- There are multiple names available. - gres -> ambiguous dflags x gres + gres -> ambiguous dflags i gres DocWarning doc -> DocWarning <$> rn doc DocEmphasis doc -> DocEmphasis <$> rn doc @@ -168,13 +170,13 @@ rename dflags gre = rn -- users shouldn't rely on this doing the right thing. See tickets -- #253 and #375 on the confusion this causes depending on which -- default we pick in 'rename'. -outOfScope :: DynFlags -> Namespace -> RdrName -> ErrMsgM (Doc a) +outOfScope :: DynFlags -> Namespace -> Wrap RdrName -> ErrMsgM (Doc a) outOfScope dflags ns x = - case x of - Unqual occ -> warnAndMonospace occ - Qual mdl occ -> pure (DocIdentifierUnchecked (mdl, occ)) - Orig _ occ -> warnAndMonospace occ - Exact name -> warnAndMonospace name -- Shouldn't happen since x is out of scope + case unwrap x of + Unqual occ -> warnAndMonospace (x $> occ) + Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ))) + Orig _ occ -> warnAndMonospace (x $> occ) + Exact name -> warnAndMonospace (x $> name) -- Shouldn't happen since x is out of scope where prefix = case ns of Value -> "the value " @@ -182,11 +184,11 @@ outOfScope dflags ns x = None -> "" warnAndMonospace a = do - tell ["Warning: " ++ prefix ++ "'" ++ showPpr dflags a ++ "' is out of scope.\n" ++ - " If you qualify the identifier, haddock can try to link it\n" ++ - " it anyway."] - pure (monospaced a) - monospaced a = DocMonospaced (DocString (showPpr dflags a)) + let a' = showWrapped (showPpr dflags) a + tell ["Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++ + " If you qualify the identifier, haddock can try to link it anyway."] + pure (monospaced a') + monospaced = DocMonospaced . DocString -- | Handle ambiguous identifiers. -- @@ -194,36 +196,42 @@ outOfScope dflags ns x = -- -- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class. ambiguous :: DynFlags - -> RdrName + -> Wrap NsRdrName -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above. -> ErrMsgM (Doc Name) ambiguous dflags x gres = do let noChildren = map availName (gresToAvailInfo gres) dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren - msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++ + msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++ concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++ " You may be able to disambiguate the identifier by qualifying it or\n" ++ " by specifying the type/value namespace explicitly.\n" ++ - " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt + " Defaulting to the one defined " ++ defnLoc dflt -- TODO: Once we have a syntax for namespace qualification (#667) we may also -- want to emit a warning when an identifier is a data constructor for a type -- of the same name, but not the only constructor. -- For example, for @data D = C | D@, someone may want to reference the @D@ -- constructor. when (length noChildren > 1) $ tell [msg] - pure (DocIdentifier dflt) + pure (DocIdentifier (x $> dflt)) where isLocalName (nameSrcLoc -> RealSrcLoc {}) = True isLocalName _ = False - x_str = '\'' : showPpr dflags x ++ "'" defnLoc = showSDoc dflags . pprNameDefnLoc -- | Handle value-namespaced names that cannot be for values. -- -- Emits a warning that the value-namespace is invalid on a non-value identifier. -invalidValue :: DynFlags -> RdrName -> ErrMsgM (Doc a) +invalidValue :: DynFlags -> Wrap NsRdrName -> ErrMsgM (Doc a) invalidValue dflags x = do - tell ["Warning: '" ++ showPpr dflags x ++ "' cannot be value, yet it is\n" ++ + tell ["Warning: " ++ showNsRdrName dflags x ++ " cannot be value, yet it is\n" ++ " namespaced as such. Did you mean to specify a type namespace\n" ++ " instead?"] - pure (DocMonospaced (DocString (showPpr dflags x))) + pure (DocMonospaced (DocString (showNsRdrName dflags x))) + +-- | Printable representation of a wrapped and namespaced name +showNsRdrName :: DynFlags -> Wrap NsRdrName -> String +showNsRdrName dflags = (\p i -> p ++ "'" ++ i ++ "'") <$> prefix <*> ident + where + ident = showWrapped (showPpr dflags . rdrName) + prefix = renderNs . namespace . unwrap diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 57e6d699..88238f04 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -173,8 +173,8 @@ renameLDocHsSyn :: LHsDocString -> RnM LHsDocString renameLDocHsSyn = return -renameDoc :: Traversable t => t Name -> RnM (t DocName) -renameDoc = traverse rename +renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName)) +renameDoc = traverse (traverse rename) renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) renameFnArgsDoc = mapM renameDoc diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index e1d8dbe1..7645b1bb 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface -- binaryInterfaceVersion :: Word16 #if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809) -binaryInterfaceVersion = 34 +binaryInterfaceVersion = 35 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -701,3 +701,28 @@ instance Binary DocName where name <- get bh return (Undocumented name) _ -> error "get DocName: Bad h" + +instance Binary n => Binary (Wrap n) where + put_ bh (Unadorned n) = do + putByte bh 0 + put_ bh n + put_ bh (Parenthesized n) = do + putByte bh 1 + put_ bh n + put_ bh (Backticked n) = do + putByte bh 2 + put_ bh n + + get bh = do + h <- getByte bh + case h of + 0 -> do + name <- get bh + return (Unadorned name) + 1 -> do + name <- get bh + return (Parenthesized name) + 2 -> do + name <- get bh + return (Backticked name) + _ -> error "get Wrap: Bad h" diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index 8b7dda7c..6d5dc103 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -15,27 +15,32 @@ module Haddock.Parser ( parseParas import qualified Documentation.Haddock.Parser as P import Documentation.Haddock.Types -import Haddock.Types (NsRdrName(..)) +import Haddock.Types import DynFlags ( DynFlags ) import FastString ( fsLit ) import Lexer ( mkPState, unP, ParseResult(POk) ) import Parser ( parseIdentifier ) -import RdrName ( RdrName ) import SrcLoc ( mkRealSrcLoc, GenLocated(..) ) import StringBuffer ( stringToStringBuffer ) -parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod NsRdrName + +parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName) parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p -parseString :: DynFlags -> String -> DocH mod NsRdrName +parseString :: DynFlags -> String -> DocH mod (Wrap NsRdrName) parseString d = P.overIdentifier (parseIdent d) . P.parseString -parseIdent :: DynFlags -> Namespace -> String -> Maybe NsRdrName +parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName) parseIdent dflags ns str0 = - let buffer = stringToStringBuffer str0 + let buffer = stringToStringBuffer str1 realSrcLc = mkRealSrcLoc (fsLit "") 0 0 pstate = mkPState dflags buffer realSrcLc + (wrap,str1) = case str0 of + '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names + -> (Parenthesized, init s) + '`' : s@(_ : _) -> (Backticked, init s) + _ -> (Unadorned, str0) in case unP parseIdentifier pstate of - POk _ (L _ name) -> Just (NsRdrName ns name) + POk _ (L _ name) -> Just (wrap (NsRdrName ns name)) _ -> Nothing diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index e8da4120..cd4ac1a1 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -42,7 +42,7 @@ import GHC import DynFlags (Language) import qualified GHC.LanguageExtensions as LangExt import OccName -import Outputable +import Outputable hiding ((<>)) ----------------------------------------------------------------------------- -- * Convenient synonyms @@ -334,6 +334,26 @@ instance SetName DocName where setName name' (Documented _ mdl) = Documented name' mdl setName name' (Undocumented _) = Undocumented name' +-- | Adds extra "wrapper" information to a name. +-- +-- This is to work around the fact that most name types in GHC ('Name', 'RdrName', +-- 'OccName', ...) don't include backticks or parens. +data Wrap n + = Unadorned { unwrap :: n } -- ^ don't do anything to the name + | Parenthesized { unwrap :: n } -- ^ add parentheses around the name + | Backticked { unwrap :: n } -- ^ add backticks around the name + deriving (Show, Functor, Foldable, Traversable) + +-- | Useful for debugging +instance Outputable n => Outputable (Wrap n) where + ppr (Unadorned n) = ppr n + ppr (Parenthesized n) = hcat [ char '(', ppr n, char ')' ] + ppr (Backticked n) = hcat [ char '`', ppr n, char '`' ] + +showWrapped :: (a -> String) -> Wrap a -> String +showWrapped f (Unadorned n) = f n +showWrapped f (Parenthesized n) = "(" ++ f n ++ ")" +showWrapped f (Backticked n) = "`" ++ f n ++ "`" ----------------------------------------------------------------------------- @@ -429,10 +449,10 @@ instance NamedThing name => NamedThing (InstOrigin name) where type LDoc id = Located (Doc id) -type Doc id = DocH (ModuleName, OccName) id -type MDoc id = MetaDoc (ModuleName, OccName) id +type Doc id = DocH (Wrap (ModuleName, OccName)) (Wrap id) +type MDoc id = MetaDoc (Wrap (ModuleName, OccName)) (Wrap id) -type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a +type DocMarkup id a = DocMarkupH (Wrap (ModuleName, OccName)) id a instance (NFData a, NFData mod) => NFData (DocH mod a) where diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index b24db5d4..5475d61b 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -49,6 +49,7 @@ library other-modules: Documentation.Haddock.Parser.Util Documentation.Haddock.Parser.Monad + Documentation.Haddock.Parser.Identifier test-suite spec import: lib-defaults @@ -70,6 +71,7 @@ test-suite spec Documentation.Haddock.Parser.UtilSpec Documentation.Haddock.ParserSpec Documentation.Haddock.Types + Documentation.Haddock.Parser.Identifier build-depends: , base-compat ^>= 0.9.3 || ^>= 0.10.0 diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index e9b1c496..36c8bb5b 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -27,8 +27,7 @@ module Documentation.Haddock.Parser ( import Control.Applicative import Control.Arrow (first) import Control.Monad -import Data.Char (chr, isUpper, isAlpha, isAlphaNum, isSpace) -import Data.Foldable (asum) +import Data.Char (chr, isUpper, isAlpha, isSpace) import Data.List (intercalate, unfoldr, elemIndex) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid @@ -37,6 +36,7 @@ import Documentation.Haddock.Doc import Documentation.Haddock.Markup ( markup, plainMarkup ) import Documentation.Haddock.Parser.Monad import Documentation.Haddock.Parser.Util +import Documentation.Haddock.Parser.Identifier import Documentation.Haddock.Types import Prelude hiding (takeWhile) import qualified Prelude as P @@ -47,37 +47,10 @@ import Text.Parsec (try) import qualified Data.Text as T import Data.Text (Text) -#if MIN_VERSION_base(4,9,0) -import Text.Read.Lex (isSymbolChar) -#else -import Data.Char (GeneralCategory (..), - generalCategory) -#endif -- $setup -- >>> :set -XOverloadedStrings -#if !MIN_VERSION_base(4,9,0) --- inlined from base-4.10.0.0 -isSymbolChar :: Char -> Bool -isSymbolChar c = not (isPuncChar c) && case generalCategory c of - MathSymbol -> True - CurrencySymbol -> True - ModifierSymbol -> True - OtherSymbol -> True - DashPunctuation -> True - OtherPunctuation -> c `notElem` ("'\"" :: String) - ConnectorPunctuation -> c /= '_' - _ -> False - where - -- | The @special@ character class as defined in the Haskell Report. - isPuncChar :: Char -> Bool - isPuncChar = (`elem` (",;()[]{}`" :: String)) -#endif - --- | Identifier string surrounded with opening and closing quotes/backticks. -data Identifier = Identifier !Namespace !Char String !Char - -- | Drops the quotes/backticks around all identifiers, as if they -- were valid but still 'String's. toRegular :: DocH mod Identifier -> DocH mod String @@ -838,34 +811,6 @@ autoUrl = mkLink <$> url mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing - --- | Parses strings between identifier delimiters. Consumes all input that it --- deems to be valid in an identifier. Note that it simply blindly consumes --- characters and does no actual validation itself. -parseValid :: Parser String -parseValid = p some - where - idChar = Parsec.satisfy (\c -> isAlphaNum c || isSymbolChar c || c == '_') - - p p' = do - vs <- p' idChar - c <- peekChar' - case c of - '`' -> return vs - '\'' -> choice' [ (\x -> vs ++ "'" ++ x) <$> ("'" *> p many), return vs ] - _ -> fail "outofvalid" - --- | Parses identifiers with help of 'parseValid'. Asks GHC for --- 'String' from the string it deems valid. +-- | Parses identifiers with help of 'parseValid'. identifier :: Parser (DocH mod Identifier) -identifier = do - ns <- asum [ Value <$ Parsec.char 'v' - , Type <$ Parsec.char 't' - , pure None - ] - o <- idDelim - vid <- parseValid - e <- idDelim - return $ DocIdentifier (Identifier ns o vid e) - where - idDelim = Parsec.oneOf "'`" +identifier = DocIdentifier <$> parseValid diff --git a/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs b/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs new file mode 100644 index 00000000..7bc98b62 --- /dev/null +++ b/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Documentation.Haddock.Parser.Identifier +-- Copyright : (c) Alec Theriault 2019, +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Functionality for parsing identifiers and operators + +module Documentation.Haddock.Parser.Identifier ( + Identifier(..), + parseValid, +) where + +import Documentation.Haddock.Types ( Namespace(..) ) +import Documentation.Haddock.Parser.Monad +import qualified Text.Parsec as Parsec +import Text.Parsec.Pos ( updatePosChar ) +import Text.Parsec ( State(..) + , getParserState, setParserState ) + +import Data.Text (Text) +import qualified Data.Text as T + +import Data.Char (isAlpha, isAlphaNum) +import Control.Monad (guard) +import Data.Functor (($>)) +#if MIN_VERSION_base(4,9,0) +import Text.Read.Lex (isSymbolChar) +#else +import Data.Char (GeneralCategory (..), + generalCategory) +#endif + +import Data.Maybe + +-- | Identifier string surrounded with namespace, opening, and closing quotes/backticks. +data Identifier = Identifier !Namespace !Char String !Char + deriving (Show, Eq) + +parseValid :: Parser Identifier +parseValid = do + s@State{ stateInput = inp, statePos = pos } <- getParserState + + case takeIdentifier inp of + Nothing -> Parsec.parserFail "parseValid: Failed to match a valid identifier" + Just (ns, op, ident, cl, inp') -> + let posOp = updatePosChar pos op + posIdent = T.foldl updatePosChar posOp ident + posCl = updatePosChar posIdent cl + s' = s{ stateInput = inp', statePos = posCl } + in setParserState s' $> Identifier ns op (T.unpack ident) cl + + +#if !MIN_VERSION_base(4,9,0) +-- inlined from base-4.10.0.0 +isSymbolChar :: Char -> Bool +isSymbolChar c = not (isPuncChar c) && case generalCategory c of + MathSymbol -> True + CurrencySymbol -> True + ModifierSymbol -> True + OtherSymbol -> True + DashPunctuation -> True + OtherPunctuation -> c `notElem` "'\"" + ConnectorPunctuation -> c /= '_' + _ -> False + where + -- | The @special@ character class as defined in the Haskell Report. + isPuncChar :: Char -> Bool + isPuncChar = (`elem` (",;()[]{}`" :: String)) +#endif + +-- | Try to parse a delimited identifier off the front of the given input. +-- +-- This tries to match as many valid Haskell identifiers/operators as possible, +-- to the point of sometimes accepting invalid things (ex: keywords). Some +-- considerations: +-- +-- - operators and identifiers can have module qualifications +-- - operators can be wrapped in parens (for prefix) +-- - identifiers can be wrapped in backticks (for infix) +-- - delimiters are backticks or regular ticks +-- - since regular ticks are also valid in identifiers, we opt for the +-- longest successful parse +-- +-- This function should make /O(1)/ allocations +takeIdentifier :: Text -> Maybe (Namespace, Char, Text, Char, Text) +takeIdentifier input = listToMaybe $ do + + -- Optional namespace + let (ns, input') = case T.uncons input of + Just ('v', i) -> (Value, i) + Just ('t', i) -> (Type, i) + _ -> (None, input) + + -- Opening tick + (op, input'') <- maybeToList (T.uncons input') + guard (op == '\'' || op == '`') + + -- Identifier/operator + (ident, input''') <- wrapped input'' + + -- Closing tick + (cl, input'''') <- maybeToList (T.uncons input''') + guard (cl == '\'' || cl == '`') + + pure (ns, op, ident, cl, input'''') + + where + + -- | Parse out a wrapped, possibly qualified, operator or identifier + wrapped t = do + (c, t' ) <- maybeToList (T.uncons t) + -- Tuples + case c of + '(' | Just (c', _) <- T.uncons t' + , c' == ',' || c' == ')' + -> do let (commas, t'') = T.span (== ',') t' + (')', t''') <- maybeToList (T.uncons t'') + pure (T.take (T.length commas + 2) t, t''') + + -- Parenthesized + '(' -> do (n, t'' ) <- general False 0 [] t' + (')', t''') <- maybeToList (T.uncons t'') + pure (T.take (n + 2) t, t''') + + -- Backticked + '`' -> do (n, t'' ) <- general False 0 [] t' + ('`', t''') <- maybeToList (T.uncons t'') + pure (T.take (n + 2) t, t''') + + -- Unadorned + _ -> do (n, t'' ) <- general False 0 [] t + pure (T.take n t, t'') + + -- | Parse out a possibly qualified operator or identifier + general :: Bool -- ^ refuse inputs starting with operators + -> Int -- ^ total characters \"consumed\" so far + -> [(Int, Text)] -- ^ accumulated results + -> Text -- ^ current input + -> [(Int, Text)] -- ^ total characters parsed & what remains + general !identOnly !i acc t + -- Starts with an identifier (either just an identifier, or a module qual) + | Just (n, rest) <- identLike t + = if T.null rest + then acc + else case T.head rest of + '`' -> (n + i, rest) : acc + ')' -> (n + i, rest) : acc + '.' -> general False (n + i + 1) acc (T.tail rest) + '\'' -> let (m, rest') = quotes rest + in general True (n + m + 1 + i) ((n + m + i, rest') : acc) (T.tail rest') + _ -> acc + + -- An operator + | Just (n, rest) <- optr t + , not identOnly + = (n + i, rest) : acc + + -- Anything else + | otherwise + = acc + + -- | Parse an identifier off the front of the input + identLike t + | T.null t = Nothing + | isAlpha (T.head t) || '_' == T.head t + = let !(idt, rest) = T.span (\c -> isAlphaNum c || c == '_') t + !(octos, rest') = T.span (== '#') rest + in Just (T.length idt + T.length octos, rest') + | otherwise = Nothing + + -- | Parse all but the last quote off the front of the input + -- PRECONDITION: T.head t == '\'' + quotes :: Text -> (Int, Text) + quotes t = let !n = T.length (T.takeWhile (== '\'') t) - 1 + in (n, T.drop n t) + + -- | Parse an operator off the front of the input + optr t = let !(op, rest) = T.span isSymbolChar t + in if T.null op then Nothing else Just (T.length op, rest) diff --git a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs index 8f5bd217..fa46f536 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs @@ -4,6 +4,18 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeSynonymInstances #-} +-- | +-- Module : Documentation.Haddock.Parser.Monad +-- Copyright : (c) Alec Theriault 2018-2019, +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Defines the Parsec monad over which all parsing is done and also provides +-- more efficient versions of the usual parsec combinator functions (but +-- specialized to 'Text'). module Documentation.Haddock.Parser.Monad where @@ -96,7 +108,6 @@ takeWhile f = do s' = s{ stateInput = inp', statePos = pos' } setParserState s' $> t - -- | Like 'takeWhile', but fails if no characters matched. -- -- Equivalent to @fmap T.pack . Parsec.many1@, but more efficient. diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index e186a5cf..bc40a0a2 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -112,7 +112,7 @@ spec = do "``" `shouldParseTo` "``" it "can parse an identifier in infix notation enclosed within backticks" $ do - "``infix``" `shouldParseTo` "`" <> DocIdentifier "infix" <> "`" + "``infix``" `shouldParseTo` DocIdentifier "`infix`" it "can parse identifiers containing a single quote" $ do "'don't'" `shouldParseTo` DocIdentifier "don't" @@ -138,6 +138,13 @@ spec = do it "can parse type-namespaced identifiers" $ do "t'foo'" `shouldParseTo` DocIdentifier "foo" + it "can parse parenthesized operators and backticked identifiers" $ do + "'(<|>)'" `shouldParseTo` DocIdentifier "(<|>)" + "'`elem`'" `shouldParseTo` DocIdentifier "`elem`" + + it "can properly figure out the end of identifiers" $ do + "'DbModule'/'DbUnitId'" `shouldParseTo` DocIdentifier "DbModule" <> "/" <> DocIdentifier "DbUnitId" + context "when parsing operators" $ do it "can parse an operator enclosed within single quotes" $ do "'.='" `shouldParseTo` DocIdentifier ".=" diff --git a/haddock.cabal b/haddock.cabal index 2b8ee6ff..91a5ea3d 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -89,6 +89,7 @@ executable haddock other-modules: Documentation.Haddock.Parser Documentation.Haddock.Parser.Monad + Documentation.Haddock.Parser.Identifier Documentation.Haddock.Types Documentation.Haddock.Doc Documentation.Haddock.Parser.Util diff --git a/html-test/ref/Identifiers.html b/html-test/ref/Identifiers.html new file mode 100644 index 00000000..1a0a18a5 --- /dev/null +++ b/html-test/ref/Identifiers.html @@ -0,0 +1,286 @@ +Identifiers
      Safe HaskellSafe

      Identifiers

      Synopsis

      Documentation

      data Id #

      Constructors

      Id 

      data a :* b #

      Constructors

      a :* b 

      foo :: () #

      diff --git a/html-test/ref/Test.html b/html-test/ref/Test.html index b76622e7..aefc4d14 100644 --- a/html-test/ref/Test.html +++ b/html-test/ref/Test.html @@ -2364,7 +2364,7 @@ is at the beginning of the line).f' - but f' doesn't get link'd 'f\''

      Date: Mon, 25 Feb 2019 21:53:56 -0800 Subject: Fix standalone deriving docs Docs on standalone deriving decls for classes with associated types should be associated with the class instance, not the associated type instance. Fixes #1033 --- haddock-api/src/Haddock/Interface/Create.hs | 4 +- html-test/ref/Bug1033.html | 222 ++++++++++++++++++++++++++++ html-test/src/Bug1033.hs | 11 ++ 3 files changed, 235 insertions(+), 2 deletions(-) create mode 100644 html-test/ref/Bug1033.html create mode 100644 html-test/src/Bug1033.hs (limited to 'html-test') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index a4408434..146c3cc8 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -132,8 +132,8 @@ createInterface tm flags modMap instIfaceMap = do fixMap = mkFixMap group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom sem_mdl) - $ map getName instances - ++ map getName fam_instances + $ map getName fam_instances + ++ map getName instances -- Locations of all TH splices splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ] diff --git a/html-test/ref/Bug1033.html b/html-test/ref/Bug1033.html new file mode 100644 index 00000000..32a9f6d3 --- /dev/null +++ b/html-test/ref/Bug1033.html @@ -0,0 +1,222 @@ +Bug1033
      Safe HaskellSafe

      Bug1033

      Documentation

      data Foo #

      Constructors

      Foo

      Instances

      Instances details
      Generic Foo #

      This does some generic foos.

      Instance details

      Defined in Bug1033

      Associated Types

      type Rep Foo :: Type -> Type #

      Methods

      from :: Foo -> Rep Foo x #

      to :: Rep Foo x -> Foo #

      type Rep Foo #
      Instance details

      Defined in Bug1033

      type Rep Foo = D1 (MetaData "Foo" "Bug1033" "main" False) (C1 (MetaCons "Foo" PrefixI False) (U1 :: Type -> Type))
      \ No newline at end of file diff --git a/html-test/src/Bug1033.hs b/html-test/src/Bug1033.hs new file mode 100644 index 00000000..fdf5a57e --- /dev/null +++ b/html-test/src/Bug1033.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Bug1033 where + +import GHC.Generics + +data Foo = Foo + +-- | This does some generic foos. +deriving instance Generic Foo -- cgit v1.2.3 From b682041ed1cbeaf5aa501f85e4e46a6d2e39da3a Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Tue, 26 Feb 2019 08:46:45 -0800 Subject: Fix bogus identifier defaulting This avoids a situation in which an identifier would get defaulted to a completely different identifier. Prior to this commit, the 'Bug1035' test case would hyperlink 'Foo' into 'Bar'! Fixes #1035. --- haddock-api/src/Haddock/Interface/LexParseRn.hs | 14 +-- html-test/ref/Bug1035.html | 146 ++++++++++++++++++++++++ html-test/src/Bug1035.hs | 9 ++ 3 files changed, 160 insertions(+), 9 deletions(-) create mode 100644 html-test/ref/Bug1035.html create mode 100644 html-test/src/Bug1035.hs (limited to 'html-test') diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index faf23728..0b40ed3c 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -19,7 +19,6 @@ module Haddock.Interface.LexParseRn , processModuleHeader ) where -import Avail import Control.Arrow import Control.Monad import Data.Functor (($>)) @@ -200,10 +199,9 @@ ambiguous :: DynFlags -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above. -> ErrMsgM (Doc Name) ambiguous dflags x gres = do - let noChildren = map availName (gresToAvailInfo gres) - dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren + let dflt = maximumBy (comparing (gre_lcl &&& isTyConName . gre_name)) gres msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++ - concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++ + concatMap (\n -> " * " ++ defnLoc n ++ "\n") gres ++ " You may be able to disambiguate the identifier by qualifying it or\n" ++ " by specifying the type/value namespace explicitly.\n" ++ " Defaulting to the one defined " ++ defnLoc dflt @@ -212,12 +210,10 @@ ambiguous dflags x gres = do -- of the same name, but not the only constructor. -- For example, for @data D = C | D@, someone may want to reference the @D@ -- constructor. - when (length noChildren > 1) $ tell [msg] - pure (DocIdentifier (x $> dflt)) + when (length (gresToAvailInfo gres) > 1) $ tell [msg] + pure (DocIdentifier (x $> gre_name dflt)) where - isLocalName (nameSrcLoc -> RealSrcLoc {}) = True - isLocalName _ = False - defnLoc = showSDoc dflags . pprNameDefnLoc + defnLoc = showSDoc dflags . pprNameDefnLoc . gre_name -- | Handle value-namespaced names that cannot be for values. -- diff --git a/html-test/ref/Bug1035.html b/html-test/ref/Bug1035.html new file mode 100644 index 00000000..946fc235 --- /dev/null +++ b/html-test/ref/Bug1035.html @@ -0,0 +1,146 @@ +Bug1035
      Safe HaskellSafe

      Bug1035

      Synopsis

      Documentation

      data Foo #

      Constructors

      Bar

      data Bar #

      Constructors

      Foo

      foo :: () #

      A link to Bar

      \ No newline at end of file diff --git a/html-test/src/Bug1035.hs b/html-test/src/Bug1035.hs new file mode 100644 index 00000000..3516c08f --- /dev/null +++ b/html-test/src/Bug1035.hs @@ -0,0 +1,9 @@ +module Bug1035 where + +data Foo = Bar + +data Bar = Foo + +-- | A link to 'Bar' +foo :: () +foo = () -- cgit v1.2.3 From abb448ff120d6f09b6d070806de1d0eb334bc23b Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Fri, 8 Mar 2019 13:23:37 -0800 Subject: Better support for default methods in classes * default methods now get rendered differently * default associated types get rendered * fix a forgotten `s/TypeSig/ClassOpSig/` refactor in LaTeX backend * LaTeX backend now renders default method signatures NB: there is still no way to document default class members and the NB: LaTeX backend still crashes on associated types --- CHANGES.md | 3 + haddock-api/src/Haddock/Backends/LaTeX.hs | 47 +++--- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 99 +++++++---- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 4 + haddock-api/src/Haddock/Types.hs | 3 + html-test/ref/DefaultAssociatedTypes.html | 158 ++++++++++++++++++ html-test/ref/DefaultSignatures.html | 182 +++++++++++++++++++++ html-test/src/DefaultAssociatedTypes.hs | 14 ++ html-test/src/DefaultSignatures.hs | 19 +++ .../ref/DefaultSignatures/DefaultSignatures.tex | 41 +++++ latex-test/ref/DefaultSignatures/haddock.sty | 57 +++++++ latex-test/ref/DefaultSignatures/main.tex | 11 ++ .../src/DefaultSignatures/DefaultSignatures.hs | 19 +++ 13 files changed, 606 insertions(+), 51 deletions(-) create mode 100644 html-test/ref/DefaultAssociatedTypes.html create mode 100644 html-test/ref/DefaultSignatures.html create mode 100644 html-test/src/DefaultAssociatedTypes.hs create mode 100644 html-test/src/DefaultSignatures.hs create mode 100644 latex-test/ref/DefaultSignatures/DefaultSignatures.tex create mode 100644 latex-test/ref/DefaultSignatures/haddock.sty create mode 100644 latex-test/ref/DefaultSignatures/main.tex create mode 100644 latex-test/src/DefaultSignatures/DefaultSignatures.hs (limited to 'html-test') diff --git a/CHANGES.md b/CHANGES.md index 15a88221..bd4317bf 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -23,6 +23,9 @@ * `--show-interface` now outputs to stdout (instead of stderr) + * Render associated type defaults and also improve rendering of + default method signatures + ## Changes in version 2.22.0 * Make `--package-version` optional for `--hoogle` (#899) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 119bbc01..d2baefac 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -295,7 +295,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode - SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode ForD _ d -> ppFor (doc, fnArgsDoc) d unicode InstD _ _ -> empty @@ -307,7 +307,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode = - ppFunSig doc [name] (hsSigType typ) unicode + ppFunSig Nothing doc [name] (hsSigType typ) unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -414,17 +414,23 @@ ppTySyn _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI - -> Bool -> LaTeX -ppFunSig doc docnames (L _ typ) unicode = +ppFunSig + :: Maybe LaTeX -- ^ a prefix to put right before the signature + -> DocForDecl DocName -- ^ documentation + -> [DocName] -- ^ pattern names in the pattern signature + -> LHsType DocNameI -- ^ type of the pattern synonym + -> Bool -- ^ unicode + -> LaTeX +ppFunSig leader doc docnames (L _ typ) unicode = ppTypeOrFunSig typ doc - ( ppTypeSig names typ False - , hsep . punctuate comma $ map ppSymName names + ( lead $ ppTypeSig names typ False + , lead $ hsep . punctuate comma $ map ppSymName names , dcolon unicode ) unicode where names = map getName docnames + lead = maybe id (<+>) leader -- | Pretty-print a pattern synonym ppLPatSig :: DocForDecl DocName -- ^ documentation @@ -433,15 +439,7 @@ ppLPatSig :: DocForDecl DocName -- ^ documentation -> Bool -- ^ unicode -> LaTeX ppLPatSig doc docnames ty unicode - = ppTypeOrFunSig typ doc - ( keyword "pattern" <+> ppTypeSig names typ False - , keyword "pattern" <+> (hsep . punctuate comma $ map ppSymName names) - , dcolon unicode - ) - unicode - where - typ = unLoc (hsSigType ty) - names = map getName docnames + = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigType ty) unicode -- | Pretty-print a type, adding documentation to the whole type and its -- arguments as needed. @@ -585,6 +583,7 @@ ppFds fds unicode = hsep (map (ppDocName . unLoc) vars2) +-- TODO: associated types, associated type defaults, docs on default methods ppClassDecl :: [DocInstance DocNameI] -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Bool -> LaTeX @@ -610,13 +609,15 @@ ppClassDecl instances doc subdocs methodTable = text "\\haddockpremethods{}" <> emph (text "Methods") $$ - vcat [ ppFunSig doc names (hsSigWcType typ) unicode - | L _ (TypeSig _ lnames typ) <- lsigs - , let doc = lookupAnySubdoc (head names) subdocs - names = map unLoc lnames ] - -- FIXME: is taking just the first name ok? Is it possible that - -- there are different subdocs for different names in a single - -- type signature? + vcat [ ppFunSig leader doc names (hsSigType typ) unicode + | L _ (ClassOpSig _ is_def lnames typ) <- lsigs + , let doc | is_def = noDocForDecl + | otherwise = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames + leader = if is_def then Just (keyword "default") else Nothing + ] + -- N.B. taking just the first name is ok. Signatures with multiple + -- names are expanded so that each name gets its own signature. instancesBit = ppDocInstances unicode instances diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index f2cab635..56a79d57 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -36,6 +36,7 @@ import Text.XHtml hiding ( name, title, p, quote ) import BasicTypes (PromotionFlag(..), isPromoted) import GHC hiding (LexicalFixity(..)) +import qualified GHC import GHC.Exts import Name import BooleanFormula @@ -75,14 +76,14 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = - ppFunSig summary links loc doc (map unLoc lnames) lty fixities + ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities splice unicode pkg qual -ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> +ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html -ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual = - ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) +ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual = + ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ) splice unicode pkg qual HideEmptyContexts where pp_typ = ppLType unicode qual HideEmptyContexts typ @@ -218,7 +219,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual - = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual + = ppFunSig summary links loc noHtml doc [name] (hsSigType typ) fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -496,7 +497,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names (hsSigType typ) + [ ppFunSig summary links loc noHtml doc names (hsSigType typ) [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -517,8 +518,9 @@ ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity) -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppClassDecl summary links instances fixities loc d subdocs - decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars - , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) + decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname@(L _ nm) + , tcdTyVars = ltyvars, tcdFDs = lfds, tcdSigs = lsigs + , tcdATs = ats, tcdATDefs = atsDefs }) splice unicode pkg qual | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual | otherwise = classheader +++ docSection curname pkg qual d @@ -535,28 +537,68 @@ ppClassDecl summary links instances fixities loc d subdocs -- Only the fixity relevant to the class header fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual - nm = tcdName decl - hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds - -- ToDo: add assocatied typ defaults - atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode pkg qual - | at <- ats - , let n = unL . fdLName $ unL at - doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs - subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - - methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ) - subfixs splice unicode pkg qual - | L _ (ClassOpSig _ _ lnames typ) <- lsigs - , name <- map unLoc lnames - , let doc = lookupAnySubdoc name subdocs - subfixs = [ f | f@(n',_) <- fixities - , name == n' ] - ] - -- N.B. taking just the first name is ok. Signatures with multiple names - -- are expanded so that each name gets its own signature. + -- Associated types + atBit = subAssociatedTypes + [ ppAssocType summary links doc at subfixs splice unicode pkg qual + <+> + subDefaults (maybeToList defTys) + | at <- ats + , let name = unL . fdLName $ unL at + doc = lookupAnySubdoc name subdocs + subfixs = filter ((== name) . fst) fixities + defTys = ppDefaultAssocTy name <$> lookupDAT name + ] + + -- Default associated types + ppDefaultAssocTy n (vs,t,d') = ppTySyn summary links [] loc d' synDecl + splice unicode pkg qual + where + synDecl = SynDecl { tcdSExt = noExt + , tcdLName = noLoc n + , tcdTyVars = vs + , tcdFixity = GHC.Prefix + , tcdRhs = t } + + lookupDAT name = Map.lookup (getName name) defaultAssocTys + defaultAssocTys = Map.fromList + [ (getName name, (vs, typ, doc)) + | L _ (FamEqn { feqn_rhs = typ + , feqn_tycon = L _ name + , feqn_pats = vs }) <- atsDefs + , let doc = noDocForDecl -- TODO: get docs for associated type defaults + ] + + -- Methods + methodBit = subMethods + [ ppFunSig summary links loc noHtml doc [name] (hsSigType typ) + subfixs splice unicode pkg qual + <+> + subDefaults (maybeToList defSigs) + | ClassOpSig _ False lnames typ <- sigs + , name <- map unLoc lnames + , let doc = lookupAnySubdoc name subdocs + subfixs = filter ((== name) . fst) fixities + defSigs = ppDefaultFunSig name <$> lookupDM name + ] + -- N.B. taking just the first name is ok. Signatures with multiple names + -- are expanded so that each name gets its own signature. + + -- Default methods + ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default") + d' [n] (hsSigType t) [] splice unicode pkg qual + + lookupDM name = Map.lookup (getOccString name) defaultMethods + defaultMethods = Map.fromList + [ (nameStr, (typ, doc)) + | ClassOpSig _ True lnames typ <- sigs + , name <- map unLoc lnames + , let doc = noDocForDecl -- TODO: get docs for method defaults + nameStr = getOccString name + ] + -- Minimal complete definition minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == @@ -565,7 +607,7 @@ ppClassDecl summary links instances fixities loc d subdocs -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns] + [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -580,6 +622,7 @@ ppClassDecl summary links instances fixities loc d subdocs where wrap | p = parens | otherwise = id ppMinimal p (Parens x) = ppMinimal p (unLoc x) + -- Instances instancesBit = ppInstances links (OriginClass nm) instances splice unicode pkg qual diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 25d8b07a..4535b897 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -35,6 +35,7 @@ module Haddock.Backends.Xhtml.Layout ( subInstances, subOrphanInstances, subInstHead, subInstDetails, subFamInstDetails, subMethods, + subDefaults, subMinimal, topDeclElem, declElem, @@ -259,6 +260,9 @@ instAnchorId iid = makeAnchorId $ "i:" ++ iid subMethods :: [Html] -> Html subMethods = divSubDecls "methods" "Methods" . subBlock +subDefaults :: [Html] -> Html +subDefaults = divSubDecls "default" "" . subBlock + subMinimal :: Html -> Html subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index cd4ac1a1..a72247e6 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -355,6 +355,9 @@ showWrapped f (Unadorned n) = f n showWrapped f (Parenthesized n) = "(" ++ f n ++ ")" showWrapped f (Backticked n) = "`" ++ f n ++ "`" +instance HasOccName DocName where + + occName = occName . getName ----------------------------------------------------------------------------- -- * Instances diff --git a/html-test/ref/DefaultAssociatedTypes.html b/html-test/ref/DefaultAssociatedTypes.html new file mode 100644 index 00000000..d456815f --- /dev/null +++ b/html-test/ref/DefaultAssociatedTypes.html @@ -0,0 +1,158 @@ +DefaultAssociatedTypes
      Safe HaskellSafe

      DefaultAssociatedTypes

      Synopsis

      Documentation

      class Foo a where #

      Documentation for Foo.

      Associated Types

      type Qux a :: * #

      Doc for Qux

      type Qux a = [a] #

      Methods

      bar :: a -> String #

      Documentation for bar and baz.

      baz :: a -> String #

      Documentation for bar and baz.

      \ No newline at end of file diff --git a/html-test/ref/DefaultSignatures.html b/html-test/ref/DefaultSignatures.html new file mode 100644 index 00000000..4bf261f7 --- /dev/null +++ b/html-test/ref/DefaultSignatures.html @@ -0,0 +1,182 @@ +DefaultSignatures
      Safe HaskellSafe

      DefaultSignatures

      Synopsis

      Documentation

      class Foo a where #

      Documentation for Foo.

      Minimal complete definition

      baz

      Methods

      bar :: a -> String #

      Documentation for bar and baz.

      default bar :: Show a => a -> String #

      baz :: a -> String #

      Documentation for bar and baz.

      baz' :: String -> a #

      Documentation for baz'.

      default baz' :: Read a => String -> a #

      \ No newline at end of file diff --git a/html-test/src/DefaultAssociatedTypes.hs b/html-test/src/DefaultAssociatedTypes.hs new file mode 100644 index 00000000..6ad197d3 --- /dev/null +++ b/html-test/src/DefaultAssociatedTypes.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DefaultSignatures, TypeFamilies #-} + +module DefaultAssociatedTypes where + +-- | Documentation for Foo. +class Foo a where + -- | Documentation for bar and baz. + bar, baz :: a -> String + + -- | Doc for Qux + type Qux a :: * + + -- | Doc for default Qux + type Qux a = [a] diff --git a/html-test/src/DefaultSignatures.hs b/html-test/src/DefaultSignatures.hs new file mode 100644 index 00000000..52d68a96 --- /dev/null +++ b/html-test/src/DefaultSignatures.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DefaultSignatures #-} + +module DefaultSignatures where + +-- | Documentation for Foo. +class Foo a where + -- | Documentation for bar and baz. + bar, baz :: a -> String + + -- | Documentation for the default signature of bar. + default bar :: Show a => a -> String + bar = show + + -- | Documentation for baz'. + baz' :: String -> a + + -- | Documentation for the default signature of baz'. + default baz' :: Read a => String -> a + baz' = read diff --git a/latex-test/ref/DefaultSignatures/DefaultSignatures.tex b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex new file mode 100644 index 00000000..4dbcda49 --- /dev/null +++ b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex @@ -0,0 +1,41 @@ +\haddockmoduleheading{DefaultSignatures} +\label{module:DefaultSignatures} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module DefaultSignatures ( + Foo(baz', baz, bar) + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +class\ Foo\ a\ where +\end{tabular}]\haddockbegindoc +Documentation for Foo.\par + +\haddockpremethods{}\emph{Methods} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +bar,\ baz\ ::\ a\ ->\ String +\end{tabular}]\haddockbegindoc +Documentation for bar and baz.\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +default\ bar\ ::\ Show\ a\ =>\ a\ ->\ String +\end{tabular}] +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +baz'\ ::\ String\ ->\ a +\end{tabular}]\haddockbegindoc +Documentation for baz'.\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +default\ baz'\ ::\ Read\ a\ =>\ String\ ->\ a +\end{tabular}] +\end{haddockdesc} +\end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/DefaultSignatures/haddock.sty b/latex-test/ref/DefaultSignatures/haddock.sty new file mode 100644 index 00000000..6e031a98 --- /dev/null +++ b/latex-test/ref/DefaultSignatures/haddock.sty @@ -0,0 +1,57 @@ +% Default Haddock style definitions. To use your own style, invoke +% Haddock with the option --latex-style=mystyle. + +\usepackage{tabulary} % see below + +% make hyperlinks in the PDF, and add an expandabale index +\usepackage[pdftex,bookmarks=true]{hyperref} + +\newenvironment{haddocktitle} + {\begin{center}\bgroup\large\bfseries} + {\egroup\end{center}} +\newenvironment{haddockprologue}{\vspace{1in}}{} + +\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} + +\newcommand{\haddockbeginheader}{\hrulefill} +\newcommand{\haddockendheader}{\noindent\hrulefill} + +% a little gap before the ``Methods'' header +\newcommand{\haddockpremethods}{\vspace{2ex}} + +% inserted before \\begin{verbatim} +\newcommand{\haddockverb}{\small} + +% an identifier: add an index entry +\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} + +% The tabulary environment lets us have a column that takes up ``the +% rest of the space''. Unfortunately it doesn't allow +% the \end{tabulary} to be in the expansion of a macro, it must appear +% literally in the document text, so Haddock inserts +% the \end{tabulary} itself. +\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} +\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} + +\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} +\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} + +\makeatletter +\newenvironment{haddockdesc} + {\list{}{\labelwidth\z@ \itemindent-\leftmargin + \let\makelabel\haddocklabel}} + {\endlist} +\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} +\makeatother + +% after a declaration, start a new line for the documentation. +% Otherwise, the documentation starts right after the declaration, +% because we're using the list environment and the declaration is the +% ``label''. I tried making this newline part of the label, but +% couldn't get that to work reliably (the space seemed to stretch +% sometimes). +\newcommand{\haddockbegindoc}{\hfill\\[1ex]} + +% spacing between paragraphs and no \parindent looks better +\parskip=10pt plus2pt minus2pt +\setlength{\parindent}{0cm} diff --git a/latex-test/ref/DefaultSignatures/main.tex b/latex-test/ref/DefaultSignatures/main.tex new file mode 100644 index 00000000..d30eb008 --- /dev/null +++ b/latex-test/ref/DefaultSignatures/main.tex @@ -0,0 +1,11 @@ +\documentclass{book} +\usepackage{haddock} +\begin{document} +\begin{titlepage} +\begin{haddocktitle} + +\end{haddocktitle} +\end{titlepage} +\tableofcontents +\input{DefaultSignatures} +\end{document} \ No newline at end of file diff --git a/latex-test/src/DefaultSignatures/DefaultSignatures.hs b/latex-test/src/DefaultSignatures/DefaultSignatures.hs new file mode 100644 index 00000000..52d68a96 --- /dev/null +++ b/latex-test/src/DefaultSignatures/DefaultSignatures.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DefaultSignatures #-} + +module DefaultSignatures where + +-- | Documentation for Foo. +class Foo a where + -- | Documentation for bar and baz. + bar, baz :: a -> String + + -- | Documentation for the default signature of bar. + default bar :: Show a => a -> String + bar = show + + -- | Documentation for baz'. + baz' :: String -> a + + -- | Documentation for the default signature of baz'. + default baz' :: Read a => String -> a + baz' = read -- cgit v1.2.3 From b4c2b90dc5c19eb5ca1420d37d1fc1b0ed184afd Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Fri, 17 May 2019 11:22:47 -0400 Subject: Unbreak #1004 test case `fail` is no longer part of `Monad`. --- html-test/ref/Bug1004.html | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) (limited to 'html-test') diff --git a/html-test/ref/Bug1004.html b/html-test/ref/Bug1004.html index 630df356..be215281 100644 --- a/html-test/ref/Bug1004.html +++ b/html-test/ref/Bug1004.html @@ -249,16 +249,6 @@ > f g a #

      fail :: String -> Product f g a #

      Safe HaskellSafe

      Bug1063

      Documentation

      class (c => d) => Implies c d #

      Instances

      Instances details
      (c => d) => Implies c d #
      Instance details

      Defined in Bug1063

      \ No newline at end of file diff --git a/html-test/src/Bug1063.hs b/html-test/src/Bug1063.hs new file mode 100644 index 00000000..c6d13a1f --- /dev/null +++ b/html-test/src/Bug1063.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE UndecidableInstances #-} +module Bug1063 where + +class (c => d) => Implies c d +instance (c => d) => Implies c d -- cgit v1.2.3 From 646c8d2752e45d9304402d4134bf1c59006610fa Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 26 May 2019 16:16:25 -0400 Subject: Regression test: promoted lists in associated types When possible, associated types with promoted lists should use the promoted list literal syntax (instead of repeated applications of ': and '[]). This was fixed in 2122de5473fd5b434af690ff9ccb1a2e58491f8c. Closes #466, --- html-test/ref/Bug466.html | 248 ++++++++++++++++++++++++++++++++++++++++++++++ html-test/src/Bug466.hs | 9 ++ 2 files changed, 257 insertions(+) create mode 100644 html-test/ref/Bug466.html create mode 100644 html-test/src/Bug466.hs (limited to 'html-test') diff --git a/html-test/ref/Bug466.html b/html-test/ref/Bug466.html new file mode 100644 index 00000000..a0c1cd87 --- /dev/null +++ b/html-test/ref/Bug466.html @@ -0,0 +1,248 @@ +Bug466
      Safe HaskellSafe

      Bug466

      Documentation

      class Cl a #

      Associated Types

      type Fam a :: [*] #

      Instances

      Instances details
      Cl X #
      Instance details

      Defined in Bug466

      Associated Types

      type Fam X :: [Type] #

      data X #

      Constructors

      X

      Instances

      Instances details
      Cl X #
      Instance details

      Defined in Bug466

      Associated Types

      type Fam X :: [Type] #

      type Fam X #
      Instance details

      Defined in Bug466

      type Fam X = '[Char]
      \ No newline at end of file diff --git a/html-test/src/Bug466.hs b/html-test/src/Bug466.hs new file mode 100644 index 00000000..ec7cde2c --- /dev/null +++ b/html-test/src/Bug466.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds, TypeFamilies, StarIsType #-} +module Bug466 where + +class Cl a where + type Fam a :: [*] + +data X = X +instance Cl X where + type Fam X = '[Char] -- cgit v1.2.3 From 9bbcd3859c9ea08b75e6964490e75236f4a73454 Mon Sep 17 00:00:00 2001 From: Alexis King Date: Mon, 30 Sep 2019 20:12:42 -0500 Subject: Fix the ignore-exports option (#1082) The `ignore-exports` option has been broken since #688, as mentioned in https://github.com/haskell/haddock/pull/766#issue-172505043. This PR fixes it. --- haddock-api/src/Haddock/Interface/Create.hs | 9 ++--- html-test/Main.hs | 6 ---- html-test/ref/IgnoreExports.html | 54 +++++++++++++++++++++++++---- html-test/src/IgnoreExports.hs | 5 ++- 4 files changed, 56 insertions(+), 18 deletions(-) (limited to 'html-test') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 463411b4..dd1d4eb3 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -83,8 +83,9 @@ createInterface tm flags modMap instIfaceMap = do (TcGblEnv { tcg_rdr_env = gre , tcg_warns = warnings - , tcg_exports = all_exports + , tcg_exports = all_exports0 }, md) = tm_internals_ tm + all_local_avails = gresToAvailInfo . filter isLocalGRE . globalRdrEnvElts $ gre -- The 'pkgName' is necessary to decide what package to mention in "@since" -- annotations. Not having it is not fatal though. @@ -111,9 +112,9 @@ createInterface tm flags modMap instIfaceMap = do let declsWithDocs = topDecls group_ exports0 = fmap (map (first unLoc)) mayExports - exports - | OptIgnoreExports `elem` opts = Nothing - | otherwise = exports0 + (all_exports, exports) + | OptIgnoreExports `elem` opts = (all_local_avails, Nothing) + | otherwise = (all_exports0, exports0) unrestrictedImportedMods -- module re-exports are only possible with diff --git a/html-test/Main.hs b/html-test/Main.hs index 26eefe4a..36e56d9a 100755 --- a/html-test/Main.hs +++ b/html-test/Main.hs @@ -54,12 +54,6 @@ ingoredTests = -- we need a reliable way to deduplicate here. -- Happens since PR #688. "B" - - -- ignore-exports flag broke with PR #688. We use - -- the Avails calculated by GHC now. Probably - -- requires a change to GHC to "ignore" a modules - -- export list reliably. - , "IgnoreExports" ] checkIgnore :: FilePath -> Bool diff --git a/html-test/ref/IgnoreExports.html b/html-test/ref/IgnoreExports.html index eed12c00..8b3390ae 100644 --- a/html-test/ref/IgnoreExports.html +++ b/html-test/ref/IgnoreExports.html @@ -4,12 +4,14 @@ />IgnoreExportsSynopsis

      Documentation

      data Foo #

      documentation for Foo

      Constructors

      Bar

      Documentation for Bar

      foo :: :: Int #

      bar :: :: Int #

      +> \ No newline at end of file diff --git a/html-test/src/IgnoreExports.hs b/html-test/src/IgnoreExports.hs index 0321ad02..edb7c4c1 100644 --- a/html-test/src/IgnoreExports.hs +++ b/html-test/src/IgnoreExports.hs @@ -1,5 +1,8 @@ {-# OPTIONS_HADDOCK ignore-exports #-} -module IgnoreExports (foo) where +module IgnoreExports (Foo, foo) where + +-- | documentation for Foo +data Foo = Bar -- ^ Documentation for Bar -- | documentation for foo foo :: Int -- cgit v1.2.3 From 2a5fc0ad50c857098558461434c29abd478ea0a1 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 23 Oct 2019 09:42:20 -0400 Subject: Reify oversaturated data family instances correctly (#1103) This fixes #1103 by adapting the corresponding patch for GHC (see https://gitlab.haskell.org/ghc/ghc/issues/17296 and https://gitlab.haskell.org/ghc/ghc/merge_requests/1877). --- haddock-api/src/Haddock/Convert.hs | 38 ++- html-test/ref/Bug1103.html | 556 +++++++++++++++++++++++++++++++++++++ html-test/src/Bug1103.hs | 24 ++ 3 files changed, 603 insertions(+), 15 deletions(-) create mode 100644 html-test/ref/Bug1103.html create mode 100644 html-test/src/Bug1103.hs (limited to 'html-test') diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index d22efc9a..5dc3a508 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -150,8 +150,7 @@ 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 - annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) - args_types_only typats + annot_typats = zipWith3 annotHsType args_poly args_types_only typats hs_rhs = synifyType WithinType [] rhs in HsIB { hsib_ext = map tyVarName tkvs , hsib_body = FamEqn { feqn_ext = noExt @@ -162,7 +161,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) , feqn_fixity = synifyFixity name , feqn_rhs = hs_rhs } } where - fam_tvs = tyConVisibleTyVars tc + args_poly = tyConArgsPolyKinded tc synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) @@ -472,17 +471,26 @@ annotHsType True ty hs_ty in noLoc (HsKindSig noExt hs_ty hs_ki) annotHsType _ _ hs_ty = hs_ty --- | For every type variable in the input, --- report whether or not the tv is poly-kinded. This is used to eventually --- feed into 'annotHsType'. -mkIsPolyTvs :: [TyVar] -> [Bool] -mkIsPolyTvs = map is_poly_tv +-- | For every argument type that a type constructor accepts, +-- report whether or not the argument is poly-kinded. This is used to +-- eventually feed into 'annotThType'. +tyConArgsPolyKinded :: TyCon -> [Bool] +tyConArgsPolyKinded tc = + map (is_poly_ty . tyVarKind) tc_vis_tvs + ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs + ++ repeat True where - is_poly_tv tv = not $ + is_poly_ty :: Type -> Bool + is_poly_ty ty = not $ isEmptyVarSet $ filterVarSet isTyVar $ - tyCoVarsOfType $ - tyVarKind tv + tyCoVarsOfType ty + + tc_vis_tvs :: [TyVar] + tc_vis_tvs = tyConVisibleTyVars tc + + tc_res_kind_vis_bndrs :: [TyCoBinder] + tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc --states of what to do with foralls: data SynifyTypeState @@ -787,8 +795,8 @@ synifyInstHead (vs, preds, cls, types) = specializeInstHead $ InstHead cls_tycon = classTyCon cls ts = filterOutInvisibleTypes cls_tycon types ts' = map (synifyType WithinType vs) ts - annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' - is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon) + annot_ts = zipWith3 annotHsType args_poly ts ts' + args_poly = tyConArgsPolyKinded cls_tycon synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs -- Convert a family instance, this could be a type family or data family @@ -827,8 +835,8 @@ synifyFamInst fi opaque = do ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs synifyTypes = map (synifyType WithinType []) ts' = synifyTypes ts - annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' - is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc) + annot_ts = zipWith3 annotHsType args_poly ts ts' + args_poly = tyConArgsPolyKinded fam_tc {- Note [Invariant: Never expand type synonyms] diff --git a/html-test/ref/Bug1103.html b/html-test/ref/Bug1103.html new file mode 100644 index 00000000..cc16017b --- /dev/null +++ b/html-test/ref/Bug1103.html @@ -0,0 +1,556 @@ +Bug1103
      Safe HaskellSafe

      Bug1103

      Documentation

      data family Foo1 :: Type -> Type #

      Instances

      Instances details
      data Foo1 Bool #
      Instance details

      Defined in Bug1103

      data Foo1 Bool = Foo1Bool
      data Foo1 (Maybe a) #
      Instance details

      Defined in Bug1103

      data Foo1 (Maybe a)

      data family Foo2 :: k -> Type #

      Instances

      Instances details
      data Foo2 (a :: Char) #
      Instance details

      Defined in Bug1103

      data Foo2 (a :: Char)
      data Foo2 Bool #
      Instance details

      Defined in Bug1103

      data Foo2 Bool = Foo2Bool
      data Foo2 (Maybe a :: Type) #
      Instance details

      Defined in Bug1103

      data Foo2 (Maybe a :: Type)
      data Foo2 (a :: Char -> Char) #
      Instance details

      Defined in Bug1103

      data Foo2 (a :: Char -> Char)

      data family Foo3 :: k #

      Instances

      Instances details
      data Foo3 #
      Instance details

      Defined in Bug1103

      data Foo3
      data Foo3 (a :: Char) #
      Instance details

      Defined in Bug1103

      data Foo3 (a :: Char)
      data Foo3 (a :: Char -> Char) #
      Instance details

      Defined in Bug1103

      data Foo3 (a :: Char -> Char)
      data Foo3 Bool #
      Instance details

      Defined in Bug1103

      data Foo3 Bool = Foo3Bool
      data Foo3 (Maybe a :: Type) #
      Instance details

      Defined in Bug1103

      data Foo3 (Maybe a :: Type)
      \ No newline at end of file diff --git a/html-test/src/Bug1103.hs b/html-test/src/Bug1103.hs new file mode 100644 index 00000000..1f387e62 --- /dev/null +++ b/html-test/src/Bug1103.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +module Bug1103 where + +import Data.Kind + +data family Foo1 :: Type -> Type +data instance Foo1 Bool = Foo1Bool +data instance Foo1 (Maybe a) + +data family Foo2 :: k -> Type +data instance Foo2 Bool = Foo2Bool +data instance Foo2 (Maybe a) +data instance Foo2 :: Char -> Type +data instance Foo2 :: (Char -> Char) -> Type where + +data family Foo3 :: k +data instance Foo3 +data instance Foo3 Bool = Foo3Bool +data instance Foo3 (Maybe a) +data instance Foo3 :: Char -> Type +data instance Foo3 :: (Char -> Char) -> Type where -- cgit v1.2.3 From dae8d9de6aaf3913a3776f1af235fb72404e9970 Mon Sep 17 00:00:00 2001 From: Kleidukos Date: Thu, 19 Mar 2020 17:12:59 +0100 Subject: Update test fixtures --- html-test/ref/Bug335.html | 6 +++--- html-test/ref/Bug953.html | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) (limited to 'html-test') diff --git a/html-test/ref/Bug335.html b/html-test/ref/Bug335.html index 8a0e0843..9e16b3ef 100644 --- a/html-test/ref/Bug335.html +++ b/html-test/ref/Bug335.html @@ -69,7 +69,7 @@ >#

      ExF:

      #

      ExG:

      \ No newline at end of file +> diff --git a/html-test/ref/Bug953.html b/html-test/ref/Bug953.html index b49b1fb6..2a430db1 100644 --- a/html-test/ref/Bug953.html +++ b/html-test/ref/Bug953.html @@ -81,7 +81,7 @@ >

      A foo

      Examples

      A bar

      Examples

      \ No newline at end of file +> -- cgit v1.2.3