aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
authorRik Steenkamp <rik@ewps.nl>2016-04-02 21:13:34 +0100
committerBen Gamari <ben@smart-cactus.org>2016-04-04 15:43:32 +0200
commit1308be34399d1819e39f6ad1ea41928681110a4a (patch)
treea30197a98350263025be8434129078a609b15c23 /haddock-api/src
parenta0ddf910f08e1e1848bb36db202c18c42f15cc07 (diff)
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 (cherry picked from commit 3ddcbd6b8e6884bd95028381176eb33bee6896fb)
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock/Convert.hs25
1 files changed, 22 insertions, 3 deletions
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 283803a3..660be723 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -36,7 +36,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 )
@@ -102,8 +102,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)
@@ -361,6 +360,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)
@@ -422,6 +425,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