aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorRyan Newton <rrnewton@gmail.com>2011-11-05 05:59:58 -0400
committerRyan Newton <rrnewton@gmail.com>2011-11-05 05:59:58 -0400
commit8ae2b7df6749d37df93a4ba5d7e3a6a2e7002b1a (patch)
tree3fcabf0b74ba1acfb6286a540388ecc7d17409cf /src
parent2deba11b49ed5ca29e947e875349f870310d3746 (diff)
Improved declNames internal error. Added a case to handle DocD.
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Interface/Create.hs27
1 files changed, 24 insertions, 3 deletions
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 057fceb7..3a2bae1f 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -34,6 +34,8 @@ import Name
import Bag
import RdrName (GlobalRdrEnv)
+-- From GHC API:
+import Outputable(ppr, runSDoc, initSDocContext)
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
-- To do this, we need access to already processed modules in the topological
@@ -263,10 +265,29 @@ declsFromClass class_ = docs ++ defs ++ sigs ++ ats
declNames :: HsDecl a -> [a]
declNames (TyClD d) = [tcdName d]
-declNames (ForD (ForeignImport n _ _ _)) = [unLoc n]
+declNames (ForD (ForeignImport n _ _)) = [unLoc n]
-- we have normal sigs only (since they are taken from ValBindsOut)
declNames (SigD sig) = sigNameNoLoc sig
-declNames _ = error "unexpected argument to declNames"
+declNames (DocD _) = []
+declNames x = error$ "unexpected argument to declNames: " ++ showHsDecl x
+
+showHsDecl x =
+ case x of
+ TyClD _ -> "TyClD" -- (TyClDecl id)
+ InstD _ -> "InstD" -- (InstDecl id)
+ DerivD _ -> "DerivD" -- (DerivDecl id)
+ ValD _ -> "ValD" -- (HsBind id)
+ SigD _ -> "SigD" -- (Sig id)
+ DefD _ -> "DefD" -- (DefaultDecl id)
+ ForD _ -> "ForD" -- (ForeignDecl id)
+ WarningD _ -> "WarningD" -- (WarnDecl id)
+ AnnD _ -> "AnnD" -- (AnnDecl id)
+ RuleD _ -> "RuleD" -- (RuleDecl id)
+ VectD _ -> "VectD" -- (VectDecl id)
+ SpliceD _ -> "SpliceD" -- (SpliceDecl id)
+ DocD _ -> "DocD" -- DocDecl
+ QuasiQuoteD _ -> "QuasiQuoteD" -- (HsQuasiQuote id)
+
-- | The top-level declarations of a module that we care about,
@@ -770,7 +791,7 @@ extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of
_ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype)))
where
lctxt = noLoc . ctxt
- ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds
+ ctxt preds = noLoc (HsClassP c (map toTypeNoLoc tvs0)) : preds
extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"