From ed43757aa371f9a532665783e27cff1703b4ac90 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 17 Dec 2018 09:25:10 -0500 Subject: Refactor names + unused functions (#982) This commit should not introduce any change in functionality! * consistently use `getOccString` to convert `Name`s to strings * compare names directly when possible (instead of comparing strings) * get rid of unused utility functions --- haddock-api/src/Haddock/Backends/LaTeX.hs | 15 ++++++--------- haddock-api/src/Haddock/Backends/Xhtml.hs | 7 ++----- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 2 +- haddock-api/src/Haddock/GhcUtils.hs | 15 --------------- .../src/Haddock/Interface/AttachInstances.hs | 14 ++------------ haddock-api/src/Haddock/Interface/Specialize.hs | 13 ++++++------- haddock-api/src/Haddock/Parser.hs | 22 +++++++++------------- 7 files changed, 26 insertions(+), 62 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 b66116bb..1222b3f1 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1049,8 +1049,8 @@ ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode = ppr_mono_lty ty1 unicode <+> ppr_op <+> ppr_mono_lty ty2 unicode where - ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op - occName = nameOccName . getName . unLoc $ op + ppr_op | isSymOcc (getOccName op) = ppLDocName op + | otherwise = char '`' <> ppLDocName op <> char '`' ppr_mono_ty (HsParTy _ ty) unicode = parens (ppr_mono_lty ty unicode) @@ -1079,16 +1079,13 @@ ppr_tylit (HsStrTy _ s) _ = text (show s) ppBinder :: OccName -> LaTeX ppBinder n - | isInfixName n = parens $ ppOccName n - | otherwise = ppOccName n + | isSymOcc n = parens $ ppOccName n + | otherwise = ppOccName n ppBinderInfix :: OccName -> LaTeX ppBinderInfix n - | isInfixName n = ppOccName n - | otherwise = cat [ char '`', ppOccName n, char '`' ] - -isInfixName :: OccName -> Bool -isInfixName n = isVarSym n || isConSym n + | isSymOcc n = ppOccName n + | otherwise = cat [ char '`', ppOccName n, char '`' ] ppSymName :: Name -> LaTeX ppSymName name diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index da8f7a53..9add4cae 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -39,7 +39,7 @@ import Haddock.GhcUtils import Control.Monad ( when, unless ) import qualified Data.ByteString.Builder as Builder import Data.Char ( toUpper, isSpace ) -import Data.List ( sortBy, isPrefixOf, intercalate, intersperse ) +import Data.List ( sortBy, isPrefixOf, intersperse ) import Data.Maybe import System.Directory import System.FilePath hiding ( () ) @@ -388,7 +388,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = d | Just item_html <- processExport True links_info unicode pkg qual item = [ Object [ "display_html" .= String (showHtmlFragment item_html) - , "name" .= String (intercalate " " (map nameString names)) + , "name" .= String (unwords (map getOccString names)) , "module" .= String (moduleString mdl) , "link" .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names))) ] @@ -406,9 +406,6 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = d exportName ExportNoDecl { expItemName } = [expItemName] exportName _ = [] - nameString :: NamedThing name => name -> String - nameString = occNameString . nameOccName . getName - nameLink :: NamedThing name => Module -> name -> String nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 395c0837..4492739b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -696,7 +696,7 @@ instanceId origin no orphan ihd = concat $ [ "o:" | orphan ] ++ [ qual origin , ":" ++ getOccString origin - , ":" ++ (occNameString . getOccName . ihdClsName) ihd + , ":" ++ getOccString (ihdClsName ihd) , ":" ++ show no ] where diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 1acfb25b..7f45bb61 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -25,7 +25,6 @@ import Exception import Outputable import Name import NameSet -import Lexeme import Module import HscTypes import GHC @@ -39,14 +38,6 @@ moduleString = moduleNameString . moduleName isNameSym :: Name -> Bool isNameSym = isSymOcc . nameOccName - -isVarSym :: OccName -> Bool -isVarSym = isLexVarSym . occNameFS - -isConSym :: OccName -> Bool -isConSym = isLexConSym . occNameFS - - getMainDeclBinder :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => HsDecl p -> [IdP p] getMainDeclBinder (TyClD _ d) = [tcdName d] @@ -141,12 +132,6 @@ isValD :: HsDecl a -> Bool isValD (ValD _ _) = True isValD _ = False - -declATs :: HsDecl a -> [IdP a] -declATs (TyClD _ d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d -declATs _ = [] - - pretty :: Outputable a => DynFlags -> a -> String pretty = showPpr diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 8f7abd16..dd6c70a5 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, MagicHash, BangPatterns #-} +{-# LANGUAGE MagicHash, BangPatterns #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -32,7 +32,6 @@ import DynFlags import CoreSyn (isOrphan) import ErrUtils import FamInstEnv -import FastString import GHC import InstEnv import Module ( ModuleSet, moduleSetElts ) @@ -40,13 +39,11 @@ import MonadUtils (liftIO) import Name import NameEnv import Outputable (text, sep, (<+>)) -import PrelNames import SrcLoc import TyCon import TyCoRep -import TysPrim( funTyCon ) +import TysPrim( funTyConName ) import Var hiding (varName) -#define FSLIT(x) (mkFastString# (x#)) type ExportedNames = Set.Set Name type Modules = Set.Set Module @@ -224,13 +221,6 @@ instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t } = (map argCount ts, n, map simplify ts, argCount t, simplify t) -funTyConName :: Name -funTyConName = mkWiredInName gHC_PRIM - (mkOccNameFS tcName FSLIT("(->)")) - funTyConKey - (ATyCon funTyCon) -- Relevant TyCon - BuiltInSyntax - -------------------------------------------------------------------------------- -- Filtering hidden instances -------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index e9511e3d..5ab3a7ee 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -15,6 +15,8 @@ import Haddock.Types import GHC import Name import FastString +import TysPrim ( funTyConName ) +import TysWiredIn ( listTyConName ) import Control.Monad import Control.Monad.Trans.State @@ -110,10 +112,7 @@ sugar = sugarOperators . sugarTuples . sugarLists sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp) - | isBuiltInSyntax name' && strName == "[]" = HsListTy NoExt ltyp - where - name' = getName name - strName = occNameString . nameOccName $ name' + | getName name == listTyConName = HsListTy NoExt ltyp sugarLists typ = typ @@ -127,7 +126,7 @@ sugarTuples typ = | isBuiltInSyntax name' && suitable = HsTupleTy NoExt HsBoxedTuple apps where name' = getName name - strName = occNameString . nameOccName $ name' + strName = getOccString name suitable = case parseTupleArity strName of Just arity -> arity == length apps Nothing -> False @@ -137,7 +136,7 @@ sugarTuples typ = sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy NoExt la lb + | funTyConName == name' = HsFunTy NoExt la lb where name' = getName name sugarOperators typ = typ @@ -182,7 +181,7 @@ parseTupleArity _ = Nothing type NameRep = FastString getNameRep :: NamedThing name => name -> NameRep -getNameRep = occNameFS . getOccName +getNameRep = getOccFS nameRepString :: NameRep -> String nameRepString = unpackFS diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index 58500f1b..e31ea6a8 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving - , FlexibleInstances, UndecidableInstances - , IncoherentInstances #-} -{-# LANGUAGE LambdaCase #-} -- | -- Module : Haddock.Parser -- Copyright : (c) Mateusz Kowalczyk 2013, @@ -19,14 +14,15 @@ module Haddock.Parser ( parseParas ) where import qualified Documentation.Haddock.Parser as P -import DynFlags (DynFlags) -import FastString (mkFastString) import Documentation.Haddock.Types -import Lexer (mkPState, unP, ParseResult(POk)) -import Parser (parseIdentifier) -import RdrName (RdrName) -import SrcLoc (mkRealSrcLoc, unLoc) -import StringBuffer (stringToStringBuffer) + +import DynFlags ( DynFlags ) +import FastString ( fsLit ) +import Lexer ( mkPState, unP, ParseResult(POk) ) +import Parser ( parseIdentifier ) +import RdrName ( RdrName ) +import SrcLoc ( mkRealSrcLoc, unLoc ) +import StringBuffer ( stringToStringBuffer ) parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod RdrName parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p @@ -37,7 +33,7 @@ parseString d = P.overIdentifier (parseIdent d) . P.parseString parseIdent :: DynFlags -> String -> Maybe RdrName parseIdent dflags str0 = let buffer = stringToStringBuffer str0 - realSrcLc = mkRealSrcLoc (mkFastString "") 0 0 + realSrcLc = mkRealSrcLoc (fsLit "") 0 0 pstate = mkPState dflags buffer realSrcLc in case unP parseIdentifier pstate of POk _ name -> Just (unLoc name) -- cgit v1.2.3