Mon Nov 20 21:00:57 UTC 2017

Repository : ssh://git@git.haskell.org/haddock

On branches: alexbiehl-patch-1,ghc-head,ghc-head1,haddock-quick,headdock-library-1.4.5,ie_avails,master,pr-filter-maps,pr/cabal-desc,travis,v2.18,wip-located-module-as,wip/D2418,wip/T12105,wip/T12105-2,wip/T12942,wip/T13163,wip/T3384,wip/embelleshed-rdr,wip/new-tree-one-param,wip/rae,wip/remove-frames,wip/remove-frames1,wip/revert-ttg-2017-11-20,wip/ttg-2017-10-13,wip/ttg-2017-10-31,wip/ttg-2017-11-06,wip/ttg2-2017-11-10,wip/ttg3-2017-11-12,wip/ttg4-constraints-2017-11-13
Link       : http://git.haskell.org/haddock.git/commitdiff/3ddcbd6b8e6884bd95028381176eb33bee6896fb

>---------------------------------------------------------------

commit 3ddcbd6b8e6884bd95028381176eb33bee6896fb
Author: Rik Steenkamp <rik at ewps.nl>
Date:   Sat Apr 2 21:13:34 2016 +0100

    Fix printing of pattern synonym types
    
    Removes the call to `patSynType :: PatSyn -> Type` in `Convert.hs` as this
    function will be removed from GHC. Instead, we use the function `patSynSig`
    and build the `HsDecl` manually. This also fixes the printing of the two
    contexts and the quantified type variables in a pattern synonym type.
    
    Reviewers: goldfire, bgamari, mpickering
    
    Differential Revision: https://phabricator.haskell.org/D2048


>---------------------------------------------------------------

3ddcbd6b8e6884bd95028381176eb33bee6896fb
 haddock-api/src/Haddock/Convert.hs | 25 ++++++++++++++++++++++---
 1 file changed, 22 insertions(+), 3 deletions(-)

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index b651c86..71a8119 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -35,7 +35,7 @@ import TyCon
 import Type
 import TyCoRep
 import TysPrim ( alphaTyVars, unliftedTypeKindTyConName )
-import TysWiredIn ( listTyConName, starKindTyConName )
+import TysWiredIn ( listTyConName, starKindTyConName, unitTy )
 import PrelNames ( hasKey, eqTyConKey, ipClassKey
                  , tYPETyConKey, ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey )
 import Unique ( getUnique )
@@ -101,8 +101,7 @@ tyThingToLHsDecl t = case t of
     (synifySigWcType ImplicitizeForAll (dataConUserType dc)))
 
   AConLike (PatSynCon ps) ->
-    allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType
-                                  (patSynType ps))
+    allOK . SigD $ PatSynSig (synifyName ps) (synifyPatSynSigType ps)
   where
     withErrs e x = return (e, x)
     allOK x = return (mempty, x)
@@ -360,6 +359,10 @@ synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name
 -- Ditto (see synifySigType)
 synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty))
 
+synifyPatSynSigType :: PatSyn -> LHsSigType Name
+-- Ditto (see synifySigType)
+synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)
+
 synifyType :: SynifyTypeState -> Type -> LHsType Name
 synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv)
 synifyType _ (TyConApp tc tys)
@@ -421,6 +424,22 @@ synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
 synifyType s (CastTy t _) = synifyType s t
 synifyType _ (CoercionTy {}) = error "synifyType:Coercion"
 
+synifyPatSynType :: PatSyn -> LHsType Name
+synifyPatSynType ps = let
+  (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps
+  req_theta' | null req_theta && not (null prov_theta && null ex_tvs) = [unitTy]
+               -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>",
+               -- i.e., an explicit empty context, which is what we need. This is not
+               -- possible by taking theta = [], as that will print no context at all
+             | otherwise = req_theta
+  sForAll []  s = s
+  sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs
+                             , hst_body  = noLoc s }
+  sQual theta s = HsQualTy   { hst_ctxt  = synifyCtx theta
+                             , hst_body  = noLoc s }
+  sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty
+  in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau
+
 synifyTyLit :: TyLit -> HsTyLit
 synifyTyLit (NumTyLit n) = HsNumTy mempty n
 synifyTyLit (StrTyLit s) = HsStrTy mempty s

