From 85dab3d6aacf867a381c8810deaf585a43d42d43 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 23 Jul 2015 19:15:13 +0200
Subject: Integrate instance specification type into class instance definition.
---
haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +-
haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 ++--
haddock-api/src/Haddock/Convert.hs | 8 ++++++--
haddock-api/src/Haddock/Interface/Rename.hs | 5 ++++-
haddock-api/src/Haddock/Types.hs | 13 ++++++++++---
5 files changed, 23 insertions(+), 9 deletions(-)
(limited to 'haddock-api')
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 59e5af3e..47087911 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -562,7 +562,7 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
ppInstHead :: Bool -> InstHead DocName -> LaTeX
ppInstHead unicode (InstHead {..}) = case ihdInstType of
- ClassInst ctx -> ppContextNoLocs ctx unicode <+> typ
+ ClassInst ctx _ _ -> ppContextNoLocs ctx unicode <+> typ
TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs
DataInst _ -> error "data instances not supported by --latex yet"
where
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 67405915..a894972e 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -531,13 +531,13 @@ ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
-> Html
ppInstHead links splice unicode qual iid mspec ihead@(InstHead {..}) =
case ihdInstType of
- ClassInst cs | Just spec <- mspec ->
+ ClassInst cs _ _ | Just spec <- mspec ->
subClsInstance (nameStr ++ "-" ++ show iid) hdr (mets spec ihead)
where
hdr = ppContextNoLocs cs unicode qual <+> typ
mets = ppInstanceSigs links splice unicode qual
nameStr = occNameString . nameOccName $ getName ihdClsName
- ClassInst cs -> ppContextNoLocs cs unicode qual <+> typ
+ ClassInst cs _ _ -> ppContextNoLocs cs unicode qual <+> typ
TypeInst rhs -> keyword "type" <+> typ
<+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
DataInst dd -> keyword "data" <+> typ
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index e51d9df7..3479780a 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -390,11 +390,15 @@ synifyKindSig :: Kind -> LHsKind Name
synifyKindSig k = synifyType WithinType k
synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
-synifyInstHead (_, preds, cls, types) = InstHead
+synifyInstHead (tyvars, preds, cls, types) = InstHead
{ ihdClsName = getName cls
, ihdKinds = map (unLoc . synifyType WithinType) ks
, ihdTypes = map (unLoc . synifyType WithinType) ts
- , ihdInstType = ClassInst $ map (unLoc . synifyType WithinType) preds
+ , ihdInstType = ClassInst
+ { clsiCtx = map (unLoc . synifyType WithinType) preds
+ , clsiTyVars = synifyTyVars tyvars
+ , clsiSigs = map (synifyIdSig WithinType) $ classMethods cls
+ }
}
where (ks,ts) = break (not . isKind) types
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 44635318..4e4d3ed9 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -264,7 +264,10 @@ renameInstHead InstHead {..} = do
kinds <- mapM renameType ihdKinds
types <- mapM renameType ihdTypes
itype <- case ihdInstType of
- ClassInst cs -> ClassInst <$> mapM renameType cs
+ ClassInst ctx bndrs sigs -> ClassInst
+ <$> mapM renameType ctx
+ <*> renameLTyVarBndrs bndrs
+ <*> mapM renameSig sigs
TypeInst ts -> TypeInst <$> traverse renameType ts
DataInst dd -> DataInst <$> renameTyClD dd
return InstHead
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index c5ca31c0..0c130cb1 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies #-}
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
@@ -324,12 +324,19 @@ instance SetName DocName where
-- | The three types of instances
data InstType name
- = ClassInst [HsType name] -- ^ Context
+ = ClassInst
+ { clsiCtx :: [HsType name]
+ , clsiTyVars :: LHsTyVarBndrs name
+ , clsiSigs :: [Sig name]
+ }
| TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side)
| DataInst (TyClDecl name) -- ^ Data constructors
instance OutputableBndr a => Outputable (InstType a) where
- ppr (ClassInst a) = text "ClassInst" <+> ppr a
+ ppr (ClassInst { .. }) = text "ClassInst"
+ <+> ppr clsiCtx
+ <+> ppr clsiTyVars
+ <+> ppr clsiSigs
ppr (TypeInst a) = text "TypeInst" <+> ppr a
ppr (DataInst a) = text "DataInst" <+> ppr a
--
cgit v1.2.3