aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Utils.hs
diff options
context:
space:
mode:
authoridontgetoutmuch <dominic@steinitz.org>2015-12-20 21:01:47 +0000
committeridontgetoutmuch <dominic@steinitz.org>2015-12-20 21:01:47 +0000
commit2bdfda1fb2e0de696ca8c6f7a152b2f85a541be9 (patch)
treecc29895f7d69f051cfec172bb0f8c2ef03552789 /haddock-api/src/Haddock/Utils.hs
parent5a57a24c44e06e964c4ea2276c842c722c4e93d9 (diff)
parentfa03f80d76f1511a811a0209ea7a6a8b6c58704f (diff)
Merge pull request #1 from haskell/ghc-head
Ghc head
Diffstat (limited to 'haddock-api/src/Haddock/Utils.hs')
-rw-r--r--haddock-api/src/Haddock/Utils.hs60
1 files changed, 54 insertions, 6 deletions
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 4fed3a1e..3510d908 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -16,6 +16,7 @@ module Haddock.Utils (
-- * Misc utilities
restrictTo, emptyHsQTvs,
toDescription, toInstalledDescription,
+ mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes,
-- * Filename utilities
moduleHtmlFile, moduleHtmlFile',
@@ -63,6 +64,7 @@ import Haddock.GhcUtils
import GHC
import Name
+import HsTypes (selectorFieldOcc)
import Control.Monad ( liftM )
import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )
@@ -123,6 +125,34 @@ toInstalledDescription = fmap mkMeta . hmi_description . instInfo
mkMeta :: Doc a -> MDoc a
mkMeta x = emptyMetaDoc { _doc = x }
+mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name
+-- Dubious, because the implicit binders are empty even
+-- though the type might have free varaiables
+mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty)
+
+addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name
+-- Add the class context to a class-op signature
+addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype))
+ = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype))))
+ -- The mkEmptySigWcType is suspicious
+ where
+ go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty }))
+ = L loc (HsForAllTy { hst_bndrs = tvs, hst_body = go ty })
+ go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
+ = L loc (HsQualTy { hst_ctxt = add_ctxt ctxt, hst_body = ty })
+ go (L loc ty)
+ = L loc (HsQualTy { hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
+
+ extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0)
+ add_ctxt (L loc preds) = L loc (extra_pred : preds)
+
+addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
+
+lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name]
+lHsQTyVarsToTypes tvs
+ = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv)))
+ | tv <- hsQTvExplicit tvs ]
+
--------------------------------------------------------------------------------
-- * Making abstract declarations
--------------------------------------------------------------------------------
@@ -150,19 +180,36 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]
restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
where
- keep d | any (\n -> n `elem` names) (map unLoc $ con_names d) =
- case con_details d of
+ keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =
+ case getConDetails h98d of
PrefixCon _ -> Just d
RecCon fields
| all field_avail (unL fields) -> Just d
- | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL (unL fields))) })
+ | otherwise -> Just (h98d { con_details = PrefixCon (field_types (map unL (unL fields))) })
-- if we have *all* the field names available, then
-- keep the record declaration. Otherwise degrade to
-- a constructor declaration. This isn't quite right, but
-- it's the best we can do.
InfixCon _ _ -> Just d
where
- field_avail (L _ (ConDeclField ns _ _)) = all (\n -> unLoc n `elem` names) ns
+ h98d = h98ConDecl d
+ h98ConDecl c@ConDeclH98{} = c
+ h98ConDecl c@ConDeclGADT{} = c'
+ where
+ (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c)
+ c' :: ConDecl Name
+ c' = ConDeclH98
+ { con_name = head (con_names c)
+ , con_qvars = Just $ HsQTvs { hsq_implicit = mempty
+ , hsq_explicit = tvs }
+ , con_cxt = Just cxt
+ , con_details = details
+ , con_doc = con_doc c
+ }
+
+ field_avail :: LConDeclField Name -> Bool
+ field_avail (L _ (ConDeclField fs _ _))
+ = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs
field_types flds = [ t | ConDeclField _ t _ <- flds ]
keep _ = Nothing
@@ -174,11 +221,12 @@ 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
-emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] }
+emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs"
+ , hsq_explicit = [] }
--------------------------------------------------------------------------------