From 2070c0fa9354365e3e672f5cbee2e04d0ef1fd02 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 14 Jul 2015 19:59:08 +0200 Subject: Refactor instance head type to record instead of a meaningless tuple. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 14 ++++---- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 21 ++++++++---- haddock-api/src/Haddock/Convert.hs | 38 +++++++++++++--------- .../src/Haddock/Interface/AttachInstances.hs | 2 +- haddock-api/src/Haddock/Interface/Rename.hs | 19 +++++++---- haddock-api/src/Haddock/Types.hs | 7 +++- 6 files changed, 63 insertions(+), 38 deletions(-) (limited to 'haddock-api/src') 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 -- cgit v1.2.3