diff options
| author | Ryan Scott <ryan.gl.scott@gmail.com> | 2020-04-05 11:48:39 -0400 |
|---|---|---|
| committer | Alec Theriault <alec.theriault@gmail.com> | 2020-04-05 09:04:43 -0700 |
| commit | 87fbc11227347da805a3d2158d462514438ca742 (patch) | |
| tree | 37c3ce949b4d8fdf6834304e362ce0b5f10199fc | |
| parent | 5d034ee2ed72839a8472dba59f83b1b348691cc5 (diff) | |
Fix #1050 by filtering out invisible AppTy arguments
This makes the `synifyType` case for `AppTy` more intelligent by
taking into consideration the visibilities of each `AppTy` argument
and filtering out any invisible arguments, as they aren't intended
to be displayed in the source code. (See #1050 for an example of what
can happen if you fail to filter these out.)
Along the way, I noticed that a special `synifyType` case for
`AppTy t1 (CoercionTy {})` could be consolidated with the case below
it, so I took the opportunity to tidy this up.
| -rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 13 | ||||
| -rw-r--r-- | html-test/ref/Bug1050.html | 110 | ||||
| -rw-r--r-- | html-test/src/Bug1050.hs | 11 |
3 files changed, 129 insertions, 5 deletions
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index d5fa3667..1a1e95bd 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -612,11 +612,14 @@ synifyType _ vs (TyConApp tc tys) in noLoc $ HsKindSig noExtField ty' full_kind' | otherwise = ty' -synifyType s vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1 -synifyType _ vs (AppTy t1 t2) = let - s1 = synifyType WithinType vs t1 - s2 = synifyType WithinType vs t2 - in noLoc $ HsAppTy noExtField s1 s2 +synifyType _ vs ty@(AppTy {}) = let + (ty_head, ty_args) = splitAppTys ty + ty_head' = synifyType WithinType vs ty_head + ty_args' = map (synifyType WithinType vs) $ + filterOut isCoercionTy $ + filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) + ty_args + in foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) ty_head' ty_args' synifyType s vs funty@(FunTy InvisArg _ _) = synifyForAllType s Inferred vs funty synifyType _ vs (FunTy VisArg t1 t2) = let s1 = synifyType WithinType vs t1 diff --git a/html-test/ref/Bug1050.html b/html-test/ref/Bug1050.html new file mode 100644 index 00000000..2d938656 --- /dev/null +++ b/html-test/ref/Bug1050.html @@ -0,0 +1,110 @@ +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><meta name="viewport" content="width=device-width, initial-scale=1" + /><title + >Bug1050</title + ><link href="#" rel="stylesheet" type="text/css" title="Linuwial" + /><link rel="stylesheet" type="text/css" href="#" + /><link rel="stylesheet" type="text/css" href="#" + /><script src="haddock-bundle.min.js" async="async" type="text/javascript" + ></script + ><script type="text/x-mathjax-config" + >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script + ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript" + ></script + ></head + ><body + ><div id="package-header" + ><span class="caption empty" + > </span + ><ul class="links" id="page-menu" + ><li + ><a href="#" + >Contents</a + ></li + ><li + ><a href="#" + >Index</a + ></li + ></ul + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >Safe-Inferred</td + ></tr + ></table + ><p class="caption" + >Bug1050</p + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >newtype</span + > <a id="t:T" class="def" + >T</a + > :: (<span class="keyword" + >forall</span + > k. k -> <a href="#" title="Data.Kind" + >Type</a + >) -> <span class="keyword" + >forall</span + > k. k -> <a href="#" title="Data.Kind" + >Type</a + > <span class="keyword" + >where</span + > <a href="#" class="selflink" + >#</a + ></p + ><div class="subs constructors" + ><p class="caption" + >Constructors</p + ><table + ><tr + ><td class="src" + ><a id="v:MkT" class="def" + >MkT</a + > :: <span class="keyword" + >forall</span + > (f :: <span class="keyword" + >forall</span + > k. k -> <a href="#" title="Data.Kind" + >Type</a + >) k (a :: k). f a -> <a href="#" title="Bug1050" + >T</a + > f a</td + ><td class="doc empty" + > </td + ></tr + ></table + ></div + ></div + ><div class="top" + ><p class="src" + ><a id="v:mkT" class="def" + >mkT</a + > :: <span class="keyword" + >forall</span + > k (f :: <span class="keyword" + >forall</span + > k1. k1 -> <a href="#" title="Data.Kind" + >Type</a + >) (a :: k). f a -> <a href="#" title="Bug1050" + >T</a + > f a <a href="#" class="selflink" + >#</a + ></p + ></div + ></div + ></div + ></body + ></html +> diff --git a/html-test/src/Bug1050.hs b/html-test/src/Bug1050.hs new file mode 100644 index 00000000..ea293e6e --- /dev/null +++ b/html-test/src/Bug1050.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +module Bug1050 where + +import Data.Kind + +newtype T :: (forall k. k -> Type) -> (forall k. k -> Type) where + MkT :: forall (f :: forall k. k -> Type) k (a :: k). f a -> T f a + +mkT = MkT |