aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2015-10-26 12:52:36 +0000
committerSimon Peyton Jones <simonpj@microsoft.com>2015-10-26 12:52:36 +0000
commita394ee884befd8cc8ba31a6071afaec7cca14e7c (patch)
treed34e9d805aa1ee8da849cc04196166412c420fa2 /haddock-api/src/Haddock
parent85b7ed6147c18611b5ef6b606f157086a8203e7d (diff)
Track wip/spj-wildcard-refactor on main repo
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs33
-rw-r--r--haddock-api/src/Haddock/Convert.hs33
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs12
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs61
-rw-r--r--haddock-api/src/Haddock/Utils.hs2
5 files changed, 80 insertions, 61 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 55075e20..8664db27 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -64,7 +64,8 @@ dropHsDocTy :: HsType a -> HsType a
dropHsDocTy = f
where
g (L src x) = L src (f x)
- f (HsForAllTy a b c d e) = HsForAllTy a b c d (g e)
+ f (HsForAllTy a e) = HsForAllTy a (g e)
+ f (HsQualTy a e) = HsQualTy a (g e)
f (HsBangTy a b) = HsBangTy a (g b)
f (HsAppTy a b) = HsAppTy (g a) (g b)
f (HsFunTy a b) = HsFunTy (g a) (g b)
@@ -81,14 +82,6 @@ outHsType :: OutputableBndr a => DynFlags -> HsType a -> String
outHsType dflags = out dflags . dropHsDocTy
-makeExplicit :: HsType a -> HsType a
-makeExplicit (HsForAllTy _ a b c d) = HsForAllTy Explicit a b c d
-makeExplicit x = x
-
-makeExplicitL :: LHsType a -> LHsType a
-makeExplicitL (L src x) = L src (makeExplicit x)
-
-
dropComment :: String -> String
dropComment (' ':'-':'-':' ':_) = []
dropComment (x:xs) = x : dropComment xs
@@ -120,22 +113,19 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl
f (TyClD d@DataDecl{}) = ppData dflags d subdocs
f (TyClD d@SynDecl{}) = ppSynonym dflags d
f (TyClD d@ClassDecl{}) = ppClass dflags d
- f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ []
- f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ []
+ f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
+ f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
f (SigD sig) = ppSig dflags sig
f _ = []
ppExport _ _ = []
ppSig :: DynFlags -> Sig Name -> [String]
-ppSig dflags (TypeSig names sig _)
+ppSig dflags (TypeSig names sig)
= [operator prettyNames ++ " :: " ++ outHsType dflags typ]
where
prettyNames = intercalate ", " $ map (out dflags) names
- typ = case unL sig of
- HsForAllTy Explicit a b c d -> HsForAllTy Implicit a b c d
- HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d
- x -> x
+ typ = unL (hsSigType sig)
ppSig _ _ = []
@@ -144,12 +134,13 @@ ppClass :: DynFlags -> TyClDecl Name -> [String]
ppClass dflags x = out dflags x{tcdSigs=[]} :
concatMap (ppSig dflags . addContext . unL) (tcdSigs x)
where
- addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs
+ addContext (TypeSig name sig) = TypeSig name (mkHsSigType (f (hsSigType sig)))
addContext (MinimalSig src sig) = MinimalSig src sig
addContext _ = error "expected TypeSig"
- f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d
- f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t)
+ f (L _ (HsForAllTy a ty)) = reL (HsForallTy a (f ty))
+ f (L _ (HsQualTy cxt ty)) = HsQualTy (reL (context : unLoc cxt)) ty
+ f ty = HsQualTy (reL [context]) ty
context = nlHsTyConApp (tcdName x)
(map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x)))
@@ -194,10 +185,10 @@ ppCtor dflags dat subdocs con
[out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs]
- funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y))
+ funs = foldr1 (\x y -> reL $ HsFunTy x y)
apps = foldl1 (\x y -> reL $ HsAppTy x y)
- typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds)
+ typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
name = out dflags $ map unL $ con_names con
resType = case con_res con of
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index f0fc108b..d74d528e 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -96,7 +96,7 @@ tyThingToLHsDecl t = case t of
-- a data-constructor alone just gets rendered as a function:
AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc]
- (synifyType ImplicitizeForAll (dataConUserType dc)) [])
+ (synifyType ImplicitizeForAll (dataConUserType dc)))
AConLike (PatSynCon ps) ->
let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps
@@ -118,10 +118,9 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
hs_rhs = synifyType WithinType rhs
(kvs, tvs) = partition isKindVar tkvs
in TyFamEqn { tfe_tycon = name
- , tfe_pats = HsWB { hswb_cts = typats
- , hswb_kvs = map tyVarName kvs
- , hswb_tvs = map tyVarName tvs
- , hswb_wcs = [] }
+ , tfe_pats = HsIB { hsib_body = typats
+ , hsib_kvs = map tyVarName kvs
+ , hsib_tvs = map tyVarName tvs }
, tfe_rhs = hs_rhs }
synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name)
@@ -310,8 +309,14 @@ synifyDataCon use_gadt_syntax dc =
else ResTyH98
-- finally we get synifyDataCon's result!
in hs_arg_tys >>=
- \hat -> return . noLoc $ ConDecl [name] Implicit -- we don't know nor care
- qvars ctx hat hs_res_ty Nothing
+ \hat -> return $ noLoc $
+ ConDecl { con_names = [name]
+ , con_explicit = False -- we don't know nor care
+ , con_qvars = qvars
+ , con_cxt = ctx
+ , con_details = hat
+ , con_res = hs_res_ty
+ , con_doc = Nothing }
-- we don't want any "deprecated GADT syntax" warnings!
False
@@ -327,7 +332,7 @@ synifyCtx :: [PredType] -> LHsContext Name
synifyCtx = noLoc . map (synifyType WithinType)
-synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name
+synifyTyVars :: [TyVar] -> LHsQTyVars Name
synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
, hsq_tvs = map synifyTyVar tvs }
where
@@ -393,15 +398,13 @@ synifyType _ (FunTy t1 t2) = let
in noLoc $ HsFunTy s1 s2
synifyType s forallty@(ForAllTy _tv _ty) =
let (tvs, ctx, tau) = tcSplitSigmaTy forallty
- sTvs = synifyTyVars tvs
- sCtx = synifyCtx ctx
- sTau = synifyType WithinType tau
- mkHsForAllTy forallPlicitness =
- noLoc $ HsForAllTy forallPlicitness Nothing sTvs sCtx sTau
+ sPhi = HsQualTy { hst_ctxt = noLoc (synifyCtx ctx)
+ , hst_body = noLoc (synify WithinType tau) }
in case s of
DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
- WithinType -> mkHsForAllTy Explicit
- ImplicitizeForAll -> mkHsForAllTy Implicit
+ WithinType -> noLoc $ HsForAllTy { hst_bndrs = synifyTyVars tvs
+ , hst_body = noLoc sPhi }
+ ImplicitizeForAll -> noLoc sPhi
synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index aa9a1c32..49d6a420 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -69,7 +69,7 @@ getMainDeclBinder _ = []
-- to correlate InstDecls with their Instance/CoAxiom Names, via the
-- instanceMap.
getInstLoc :: InstDecl name -> SrcSpan
-getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l
+getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)
getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l
getInstLoc (TyFamInstD (TyFamInstDecl
-- Since CoAxioms' Names refer to the whole line for type family instances
@@ -92,10 +92,10 @@ filterSigNames p (FixSig (FixitySig ns ty)) =
[] -> Nothing
filtered -> Just (FixSig (FixitySig filtered ty))
filterSigNames _ orig@(MinimalSig _ _) = Just orig
-filterSigNames p (TypeSig ns ty nwcs) =
+filterSigNames p (TypeSig ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (TypeSig filtered ty nwcs)
+ filtered -> Just (TypeSig filtered ty)
filterSigNames _ _ = Nothing
ifTrueJust :: Bool -> name -> Maybe name
@@ -106,8 +106,8 @@ sigName :: LSig name -> [name]
sigName (L _ sig) = sigNameNoLoc sig
sigNameNoLoc :: Sig name -> [name]
-sigNameNoLoc (TypeSig ns _ _) = map unLoc ns
-sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n]
+sigNameNoLoc (TypeSig ns _) = map unLoc ns
+sigNameNoLoc (PatSynSig n _) = [unLoc n]
sigNameNoLoc (SpecSig n _ _) = [unLoc n]
sigNameNoLoc (InlineSig n _) = [unLoc n]
sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns
@@ -199,7 +199,7 @@ instance Parent (TyClDecl Name) where
$ (dd_cons . tcdDataDefn) $ d
| isClassDecl d =
map (unL . fdLName . unL) (tcdATs d) ++
- [ unL n | L _ (TypeSig ns _ _) <- tcdSigs d, n <- ns ]
+ [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]
| otherwise = []
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 033246a8..318a88c0 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -170,6 +170,12 @@ renameFnArgsDoc = mapM renameDoc
renameLType :: LHsType Name -> RnM (LHsType DocName)
renameLType = mapM renameType
+renameLSigType :: LHsWcSigType Name -> RnM (LHsType DocName)
+renameLSigType = renameWc renameLType
+
+renameLWcSigType :: LHsWcSigType Name -> RnM (LHsType DocName)
+renameLWcSigType = renameImplicit renameLSigType
+
renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
renameLKind = renameLType
@@ -198,11 +204,15 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn
renameType :: HsType Name -> RnM (HsType DocName)
renameType t = case t of
- HsForAllTy expl extra tyvars lcontext ltype -> do
+ HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do
tyvars' <- renameLTyVarBndrs tyvars
+ ltype' <- renameLType ltype
+ return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' })
+
+ HsQualTy { hst_cttx = lcontext , hst_body = ltype } -> do
lcontext' <- renameLContext lcontext
ltype' <- renameLType ltype
- return (HsForAllTy expl extra tyvars' lcontext' ltype')
+ return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' })
HsTyVar n -> return . HsTyVar =<< rename n
HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
@@ -252,7 +262,7 @@ renameType t = case t of
HsSpliceTy _ _ -> error "renameType: HsSpliceTy"
HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
-renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName)
+renameLTyVarBndrs :: LHsQTyVars Name -> RnM (LHsQTyVars DocName)
renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
= do { tvs' <- mapM renameLTyVarBndr tvs
; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) }
@@ -423,16 +433,16 @@ renameLFieldOcc (L l (FieldOcc lbl sel)) = do
renameSig :: Sig Name -> RnM (Sig DocName)
renameSig sig = case sig of
- TypeSig lnames ltype _ -> do
+ TypeSig lnames ltype -> do
lnames' <- mapM renameL lnames
- ltype' <- renameLType ltype
- return (TypeSig lnames' ltype' PlaceHolder)
+ ltype' <- renameLWcSigType ltype
+ return (TypeSig lnames' ltype')
PatSynSig lname (flag, qtvs) lreq lprov lty -> do
lname' <- renameL lname
qtvs' <- renameLTyVarBndrs qtvs
lreq' <- renameLContext lreq
lprov' <- renameLContext lprov
- lty' <- renameLType lty
+ lty' <- renameLSigType lty
return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty'
FixSig (FixitySig lnames fixity) -> do
lnames' <- mapM renameL lnames
@@ -445,11 +455,11 @@ renameSig sig = case sig of
renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName)
renameForD (ForeignImport lname ltype co x) = do
lname' <- renameL lname
- ltype' <- renameLType ltype
+ ltype' <- renameLSigType ltype
return (ForeignImport lname' ltype' co x)
renameForD (ForeignExport lname ltype co x) = do
lname' <- renameL lname
- ltype' <- renameLType ltype
+ ltype' <- renameLSigType ltype
return (ForeignExport lname' ltype' co x)
@@ -484,33 +494,48 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
, tfid_fvs = placeHolderNames }) }
renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName)
-renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, tfe_rhs = rhs }))
+renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs }))
= do { tc' <- renameL tc
- ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
+ ; pats' <- renameImplicit (mapM renameLType) pats
; rhs' <- renameLType rhs
; return (L loc (TyFamEqn { tfe_tycon = tc'
- , tfe_pats = HsWB pats' PlaceHolder PlaceHolder PlaceHolder
+ , tfe_pats = pats'
, tfe_rhs = rhs' })) }
renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName)
renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs }))
- = do { tc' <- renameL tc
- ; tvs' <- renameLTyVarBndrs tvs
+ = do { tc' <- renameL tc
+ ; tvs' <- renameLTyVarBndrs tvs
; rhs' <- renameLType rhs
; return (L loc (TyFamEqn { tfe_tycon = tc'
, tfe_pats = tvs'
, tfe_rhs = rhs' })) }
renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)
-renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn })
+renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_defn = defn })
= do { tc' <- renameL tc
- ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
+ ; pats' <- renameImplicit (mapM renameLType) pats
; defn' <- renameDataDefn defn
; return (DataFamInstDecl { dfid_tycon = tc'
- , dfid_pats
- = HsWB pats' PlaceHolder PlaceHolder PlaceHolder
+ , dfid_pats = pats'
, dfid_defn = defn', dfid_fvs = placeHolderNames }) }
+renameImplicit :: (in_thing -> RnM out_thing)
+ -> HsImplicitBndrs Name in_thing
+ -> RnM (HsImplicitBndrs DocName out_thing)
+renameImplicit rn_thing (HsIB { hsib_body = thing })
+ = do { thing' <- rn_thing thing
+ ; return (HsIB { hsib_body = thing'
+ , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder })
+
+renameWc :: (in_thing -> RnM out_thing)
+ -> HsWildcardBndrs Name in_thing
+ -> RnM (HsWildcardBndrs DocName out_thing)
+renameWc rn_thing (HsWC { hswc_body = thing })
+ = do { thing' <- rn_thing thing
+ ; return (HsWC { hswc_body = thing'
+ , hswc_wcs = PlaceHolder, hswc_ctx = Nothing })
+
renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
renameExportItem item = case item of
ExportModule mdl -> return (ExportModule mdl)
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index c2e1b09a..3964c86a 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -177,7 +177,7 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name]
restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
-emptyHsQTvs :: LHsTyVarBndrs Name
+emptyHsQTvs :: LHsQTyVars Name
-- This function is here, rather than in HsTypes, because it *renamed*, but
-- does not necessarily have all the rigt kind variables. It is used
-- in Haddock just for printing, so it doesn't matter