aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/GhcUtils.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/GhcUtils.hs
parent5a57a24c44e06e964c4ea2276c842c722c4e93d9 (diff)
parentfa03f80d76f1511a811a0209ea7a6a8b6c58704f (diff)
Merge pull request #1 from haskell/ghc-head
Ghc head
Diffstat (limited to 'haddock-api/src/Haddock/GhcUtils.hs')
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs36
1 files changed, 23 insertions, 13 deletions
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 5caefa77..4e5e008b 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -16,7 +16,6 @@
module Haddock.GhcUtils where
-import Control.Applicative ( (<$>) )
import Control.Arrow
import Data.Function
@@ -69,7 +68,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 +91,14 @@ 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 p (ClassOpSig is_default ns ty) =
+ case filter (p . unLoc) ns of
+ [] -> Nothing
+ filtered -> Just (ClassOpSig is_default filtered ty)
filterSigNames _ _ = Nothing
ifTrueJust :: Bool -> name -> Maybe name
@@ -106,13 +109,19 @@ 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 (SpecSig n _ _) = [unLoc n]
-sigNameNoLoc (InlineSig n _) = [unLoc n]
+sigNameNoLoc (TypeSig ns _) = map unLoc ns
+sigNameNoLoc (ClassOpSig _ 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
sigNameNoLoc _ = []
+-- | Was this signature given by the user?
+isUserLSig :: LSig name -> Bool
+isUserLSig (L _(TypeSig {})) = True
+isUserLSig (L _(ClassOpSig {})) = True
+isUserLSig _ = False
isTyClD :: HsDecl a -> Bool
isTyClD (TyClD _) = True
@@ -188,17 +197,18 @@ class Parent a where
instance Parent (ConDecl Name) where
children con =
- case con_details con of
- RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields)
+ case getConDetails con of
+ RecCon fields -> map (selectorFieldOcc . unL) $
+ concatMap (cd_fld_names . unL) (unL fields)
_ -> []
instance Parent (TyClDecl Name) where
children d
- | isDataDecl d = map unL $ concatMap (con_names . unL)
+ | isDataDecl d = map unL $ concatMap (getConNames . unL)
$ (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 = []
@@ -208,7 +218,7 @@ family = getName &&& children
familyConDecl :: ConDecl Name -> [(Name, [Name])]
-familyConDecl d = zip (map unL (con_names d)) (repeat $ children d)
+familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d)
-- | A mapping from the parent (main-binder) to its children and from each
-- child to its grand-children, recursively.