aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
authorƁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-07-14 19:59:08 +0200
committerMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2015-08-21 18:22:30 +0100
commit2070c0fa9354365e3e672f5cbee2e04d0ef1fd02 (patch)
tree25d3b23b7fc309e87e815f352bbb5c86131545e9 /haddock-api
parent92f0b1eacb2e1169dedd22df26976219c3fbc637 (diff)
Refactor instance head type to record instead of a meaningless tuple.
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs14
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs21
-rw-r--r--haddock-api/src/Haddock/Convert.hs38
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs19
-rw-r--r--haddock-api/src/Haddock/Types.hs7
6 files changed, 63 insertions, 38 deletions
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 2febd5ae..59e5af3e 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1,4 +1,5 @@
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# LANGUAGE RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.LaTeX
@@ -560,12 +561,13 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
ppInstHead :: Bool -> InstHead DocName -> LaTeX
-ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode
-ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type"
- <+> ppAppNameTypes n ks ts unicode
- <+> maybe empty (\t -> equals <+> ppType unicode t) rhs
-ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) =
- error "data instances not supported by --latex yet"
+ppInstHead unicode (InstHead {..}) = case ihdInstType of
+ ClassInst ctx -> ppContextNoLocs ctx unicode <+> typ
+ TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs
+ DataInst _ -> error "data instances not supported by --latex yet"
+ where
+ typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode
+ tibody = maybe empty (\t -> equals <+> ppType unicode t)
lookupAnySubdoc :: (Eq name1) =>
name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index a5f3676e..afbbaad1 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TransformListComp #-}
+{-# LANGUAGE RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.Html.Decl
@@ -507,15 +508,21 @@ ppInstances links instances _ baseName unicode qual
where
instName = getOccString $ getName baseName
instDecl :: DocInstance DocName -> (SubDecl,Located DocName)
- instDecl (inst, maybeDoc,l) = ((instHead inst, maybeDoc, []),l)
- instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
- <+> ppAppNameTypes n ks ts unicode qual
- instHead (n, ks, ts, TypeInst rhs) = keyword "type"
- <+> ppAppNameTypes n ks ts unicode qual
+ instDecl (inst, maybeDoc,l) =
+ ((ppInstHead links unicode qual inst, maybeDoc, []),l)
+
+ppInstHead :: LinksInfo -> Unicode -> Qualification
+ -> InstHead DocName
+ -> Html
+ppInstHead _ unicode qual (InstHead {..}) = case ihdInstType of
+ ClassInst cs -> ppContextNoLocs cs unicode qual <+> typ
+ TypeInst rhs -> keyword "type" <+> typ
<+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
- instHead (n, ks, ts, DataInst dd) = keyword "data"
- <+> ppAppNameTypes n ks ts unicode qual
+ DataInst dd -> keyword "data" <+> typ
<+> ppShortDataDecl False True dd unicode qual
+ where
+ typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
+
lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 5cbf5f97..e51d9df7 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -390,23 +390,29 @@ synifyKindSig :: Kind -> LHsKind Name
synifyKindSig k = synifyType WithinType k
synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
-synifyInstHead (_, preds, cls, types) =
- ( getName cls
- , map (unLoc . synifyType WithinType) ks
- , map (unLoc . synifyType WithinType) ts
- , ClassInst $ map (unLoc . synifyType WithinType) preds
- )
+synifyInstHead (_, 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
+ }
where (ks,ts) = break (not . isKind) types
-- Convert a family instance, this could be a type family or data family
synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name)
-synifyFamInst fi opaque =
- let fff = case fi_flavor fi of
- SynFamilyInst | opaque -> return $ TypeInst Nothing
- SynFamilyInst ->
- return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
- DataFamilyInst c ->
- synifyTyCon (Just $ famInstAxiom fi) c >>= return . DataInst
- in fff >>= \f' -> return (fi_fam fi , map (unLoc . synifyType WithinType) ks,
- map (unLoc . synifyType WithinType) ts , f')
- where (ks,ts) = break (not . isKind) $ fi_tys fi
+synifyFamInst fi opaque = do
+ ityp' <- ityp $ fi_flavor fi
+ return InstHead
+ { ihdClsName = fi_fam fi
+ , ihdKinds = synifyTypes ks
+ , ihdTypes = synifyTypes ts
+ , ihdInstType = ityp'
+ }
+ where
+ ityp SynFamilyInst | opaque = return $ TypeInst Nothing
+ ityp SynFamilyInst =
+ return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
+ ityp (DataFamilyInst c) =
+ DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c
+ (ks,ts) = break (not . isKind) $ fi_tys fi
+ synifyTypes = map (unLoc. synifyType WithinType)
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index fc530507..e2fd24ee 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -108,7 +108,7 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
attachFixities e = e
-- spanName: attach the location to the name that is the same file as the instance location
- spanName s (clsn,_,_,_) (L instL instn) =
+ spanName s (InstHead { ihdClsName = clsn }) (L instL instn) =
let s1 = getSrcSpan s
sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL
then instn
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 1a559764..d222c6d2 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RecordWildCards #-}
----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.Rename
@@ -261,16 +262,20 @@ renameLContext (L loc context) = do
return (L loc context')
renameInstHead :: InstHead Name -> RnM (InstHead DocName)
-renameInstHead (className, k, types, rest) = do
- className' <- rename className
- k' <- mapM renameType k
- types' <- mapM renameType types
- rest' <- case rest of
+renameInstHead InstHead {..} = do
+ cname <- rename ihdClsName
+ kinds <- mapM renameType ihdKinds
+ types <- mapM renameType ihdTypes
+ itype <- case ihdInstType of
ClassInst cs -> ClassInst <$> mapM renameType cs
TypeInst ts -> TypeInst <$> traverse renameType ts
DataInst dd -> DataInst <$> renameTyClD dd
- return (className', k', types', rest')
-
+ return InstHead
+ { ihdClsName = cname
+ , ihdKinds = kinds
+ , ihdTypes = types
+ , ihdInstType = itype
+ }
renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName)
renameLDecl (L loc d) = return . L loc =<< renameDecl d
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 6dd64506..d9ae6cab 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -308,7 +308,12 @@ type DocInstance name = (InstHead name, Maybe (MDoc name), Located name)
-- | The head of an instance. Consists of a class name, a list of kind
-- parameters, a list of type parameters and an instance type
-type InstHead name = (name, [HsType name], [HsType name], InstType name)
+data InstHead name = InstHead
+ { ihdClsName :: name
+ , ihdKinds :: [HsType name]
+ , ihdTypes :: [HsType name]
+ , ihdInstType :: InstType name
+ }
-----------------------------------------------------------------------------
-- * Documentation comments