diff options
Diffstat (limited to 'src/HaskellCodeExplorer/GhcUtils.hs')
| -rw-r--r-- | src/HaskellCodeExplorer/GhcUtils.hs | 1528 |
1 files changed, 722 insertions, 806 deletions
diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs index f8a2b06..89cd4bc 100644 --- a/src/HaskellCodeExplorer/GhcUtils.hs +++ b/src/HaskellCodeExplorer/GhcUtils.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} @@ -28,7 +27,7 @@ module HaskellCodeExplorer.GhcUtils , hsGroupVals , hsPatSynDetails , ieLocNames - , ghcDL + , ghcDL -- * Lookups , lookupIdInTypeEnv , lookupNameModuleAndPackage @@ -60,198 +59,222 @@ module HaskellCodeExplorer.GhcUtils , hsDocsToDocH , subordinateNamesWithDocs ) where -import GHC.Data.Bag (bagToList) -import GHC.Core.ConLike (ConLike(..)) -import GHC.HsToCore.Docs - ( collectDocs - , ungroup - , mkDecls - ) -import qualified Data.ByteString as BS -import Data.Hashable (Hashable,hash) -import qualified Data.ByteString.Internal as BSI -import Data.Char (isAlpha, isAlphaNum, isAscii, ord) -import Data.Generics (Data) -import Data.Generics.SYB (everything, everywhere, mkQ, mkT) -import qualified Data.Generics.Uniplate.Data() -import qualified Data.HashMap.Strict as HM -import qualified Data.List as L -import Data.Maybe (fromMaybe, isJust, mapMaybe) -import qualified Data.Text as T -import GHC.Core.DataCon (dataConWorkId) -import Documentation.Haddock.Parser (overIdentifier, parseParas) -import Documentation.Haddock.Types - ( DocH(..) - , Header(..) - , _doc - , Namespace - ) -import GHC.Data.FastString - ( mkFastString - , unpackFS - ) -import GHC - ( DynFlags - , sortLocatedA - , getRecConArgs_maybe - , ConDeclField(..) - , CollectFlag(..) - , LHsBindLR - , reLocN - , unXRec - , UnXRec - , GhcPass - , recordPatSynField - , HsDocString - , InstDecl(..) - , Name - , SrcSpan(..) - , RealSrcSpan(..) - , ClsInstDecl(..) - , TyClDecl(..) - , HsDataDefn(..) - , NewOrData(..) - , Id - , rdrNameFieldOcc - , HsGroup(..) - , HsValBindsLR(..) - , HsPatSynDetails - , Located - , IE(..) - , TyThing(..) - , LHsDecl - , HsDecl(..) - , ConDecl(..) - , HsConDetails(..) - , DataFamInstDecl(..) - , Sig(..) - , ForeignDecl(..) - , FixitySig(..) - , tcdName - , collectHsBindBinders - , getLocA - , getConNames - , NHsValBindsLR(..) - , unpackHDS - , NoExtField(..) - , extFieldOcc - , LIEWrappedName - , ieLWrappedName - , FamEqn(..) - , tyConKind - , nameSrcSpan - , srcSpanFile - , srcSpanStartLine - , srcSpanEndLine - , srcSpanStartCol - , srcSpanEndCol - , isExternalName - , recordPatSynPatVar - , isGoodSrcSpan - , isLocalId - , isDataFamilyDecl - , tyFamInstDeclName - , idType - , tfid_eqn - ) - -import qualified HaskellCodeExplorer.Types as HCE -import GHC.Types.TypeEnv (TypeEnv, lookupTypeEnv) -import GHC.Hs.Extension (GhcRn) -import Language.Haskell.Syntax.Extension (IdP) -import GHC.Types.Id.Info (IdDetails(..)) -import GHC.Core.InstEnv (ClsInst(..)) -import GHC.Parser.Lexer - ( ParseResult(POk) - , initParserState - , unP - ) -import GHC.Types.Name - ( isDataConNameSpace - , isDerivedOccName - , isInternalName - , isSystemName - , isTvNameSpace - , isTyConName - , isValNameSpace - , isWiredInName - , mkInternalName - , mkOccName - , nameModule_maybe - , nameOccName - , nameUnique - , occNameFS - , occNameSpace - , occNameString - , wiredInNameTyThing_maybe - ) -import GHC.Types.Name.Occurrence (OccName) -import GHC.Utils.Outputable (Outputable, ppr) -import GHC.Driver.Config (initParserOpts) -import GHC.Driver.Ppr (showPpr, showSDoc) -import GHC.Unit.State - ( LookupResult(..) - , lookupModuleWithSuggestions - , lookupUnit - ) -import GHC.Data.Pair (pSnd) -import GHC.Parser (parseIdentifier) -import GHC.Core.PatSyn (PatSyn, patSynMatcher, patSynSig) -import Prelude hiding (id, span) -import GHC.Types.Name.Reader - ( GlobalRdrEnv - , RdrName(..) - , grePrintableName - , lookupGRE_RdrName) -import GHC.Rename.Env (dataTcOccs) -import GHC.Types.SrcLoc - ( GenLocated(..) - , mkRealSrcLoc - , unLoc - ) -import GHC.Data.StringBuffer (StringBuffer(..), stringToStringBuffer) -import System.FilePath (normalise) -import GHC.Tc.Types.Evidence (HsWrapper(..), tcCoercionKind) -import GHC.Tc.Utils.TcType (evVarPred) -import GHC.Core.TyCo.Rep - ( Type(..) - , mkVisFunTyMany - , mkVisFunTys - , mkVisFunTysMany - , scaledThing - ) -import GHC.Core.TyCon (tyConName) -import GHC.Core.Type - ( coreView - , expandTypeSynonyms - , mkForAllTy - , mkTyCoInvForAllTys - , piResultTy - , splitFunTy_maybe - , tidyOpenType - ) -import GHC.Core.TyCo.Ppr (pprSigmaType) -import GHC.CoreToIface -import GHC.Iface.Type -import GHC.Builtin.Types (unitTy) -import GHC.Types.Unique.Set (emptyUniqSet, unionUniqSets, - nonDetEltsUniqSet - ) -import GHC.Types.Unique (getKey) -import GHC.Types.Var - ( idDetails - , isId - , mkTyVar - , mkCoVar - , setVarType - , varName - , varType - , varUnique - ) -import GHC.Types.Var.Env (TidyEnv) -import GHC.Types.Var.Set (VarSet, emptyVarSet, unionVarSet, unitVarSet - ) -import GHC.Unit +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BSI +import Data.Char ( isAlpha + , isAlphaNum + , isAscii + , ord + ) +import Data.Generics ( Data ) +import Data.Generics.SYB ( everything + , everywhere + , mkQ + , mkT + ) +import qualified Data.Generics.Uniplate.Data ( ) +import qualified Data.HashMap.Strict as HM +import Data.Hashable ( Hashable + , hash + ) +import qualified Data.List as L +import Data.Maybe ( fromMaybe + , isJust + , mapMaybe + ) +import qualified Data.Text as T +import Documentation.Haddock.Parser ( overIdentifier + , parseParas + ) +import Documentation.Haddock.Types ( DocH(..) + , Header(..) + , Namespace + , _doc + ) +import GHC ( ClsInstDecl(..) + , CollectFlag(..) + , ConDecl(..) + , ConDeclField(..) + , DataFamInstDecl(..) + , DynFlags + , FamEqn(..) + , FixitySig(..) + , ForeignDecl(..) + , GhcPass + , HsConDetails(..) + , HsDataDefn(..) + , HsDecl(..) + , HsDocString + , HsGroup(..) + , HsPatSynDetails + , HsValBindsLR(..) + , IE(..) + , Id + , InstDecl(..) + , LHsBindLR + , LHsDecl + , LIEWrappedName + , Located + , NHsValBindsLR(..) + , Name + , NewOrData(..) + , NoExtField(..) + , RealSrcSpan(..) + , Sig(..) + , SrcSpan(..) + , TyClDecl(..) + , TyThing(..) + , UnXRec + , collectHsBindBinders + , extFieldOcc + , getConNames + , getLocA + , getRecConArgs_maybe + , idType + , ieLWrappedName + , isDataFamilyDecl + , isExternalName + , isGoodSrcSpan + , isLocalId + , nameSrcSpan + , rdrNameFieldOcc + , reLocN + , recordPatSynField + , recordPatSynPatVar + , sortLocatedA + , srcSpanEndCol + , srcSpanEndLine + , srcSpanFile + , srcSpanStartCol + , srcSpanStartLine + , tcdName + , tfid_eqn + , tyConKind + , tyFamInstDeclName + , unXRec + , unpackHDS + ) +import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Core.DataCon ( dataConWorkId ) +import GHC.Data.Bag ( bagToList ) +import GHC.Data.FastString ( mkFastString + , unpackFS + ) +import GHC.HsToCore.Docs ( collectDocs + , mkDecls + , ungroup + ) + +import GHC.Builtin.Types ( unitTy ) +import GHC.Core.InstEnv ( ClsInst(..) ) +import GHC.Core.PatSyn ( PatSyn + , patSynMatcher + , patSynSig + ) +import GHC.Core.TyCo.Ppr ( pprSigmaType ) +import GHC.Core.TyCo.Rep ( Type(..) + , mkVisFunTyMany + , mkVisFunTys + , mkVisFunTysMany + , scaledThing + ) +import GHC.Core.TyCon ( tyConName ) +import GHC.Core.Type ( coreView + , expandTypeSynonyms + , mkForAllTy + , mkTyCoInvForAllTys + , piResultTy + , splitFunTy_maybe + , tidyOpenType + ) +import GHC.CoreToIface +import GHC.Data.Pair ( pSnd ) +import GHC.Data.StringBuffer ( StringBuffer(..) + , stringToStringBuffer + ) +import GHC.Driver.Config ( initParserOpts ) +import GHC.Driver.Ppr ( showPpr + , showSDoc + ) +import GHC.Hs.Extension ( GhcRn ) +import GHC.Iface.Type +import GHC.Parser ( parseIdentifier ) +import GHC.Parser.Lexer ( ParseResult(POk) + , initParserState + , unP + ) +import GHC.Rename.Env ( dataTcOccs ) +import GHC.Tc.Types.Evidence ( HsWrapper(..) + , tcCoercionKind + ) +import GHC.Tc.Utils.TcType ( evVarPred ) +import GHC.Types.Id.Info ( IdDetails(..) ) +import GHC.Types.Name ( isDataConNameSpace + , isDerivedOccName + , isInternalName + , isSystemName + , isTvNameSpace + , isTyConName + , isValNameSpace + , isWiredInName + , mkInternalName + , mkOccName + , nameModule_maybe + , nameOccName + , nameUnique + , occNameFS + , occNameSpace + , occNameString + , wiredInNameTyThing_maybe + ) +import GHC.Types.Name.Occurrence ( OccName ) +import GHC.Types.Name.Reader ( GlobalRdrEnv + , RdrName(..) + , grePrintableName + , lookupGRE_RdrName + ) +import GHC.Types.SrcLoc ( GenLocated(..) + , mkRealSrcLoc + , unLoc + ) +import GHC.Types.TypeEnv ( TypeEnv + , lookupTypeEnv + ) +import GHC.Types.Unique ( getKey ) +import GHC.Types.Unique.Set ( emptyUniqSet + , nonDetEltsUniqSet + , unionUniqSets + ) +import GHC.Types.Var ( idDetails + , isId + , mkCoVar + , mkTyVar + , setVarType + , varName + , varType + , varUnique + ) +import GHC.Types.Var.Env ( TidyEnv ) +import GHC.Types.Var.Set ( VarSet + , emptyVarSet + , unionVarSet + , unitVarSet + ) +import GHC.Unit +import GHC.Unit.State ( LookupResult(..) + , lookupModuleWithSuggestions + , lookupUnit + ) +import GHC.Utils.Outputable ( Outputable + , ppr + ) +import qualified HaskellCodeExplorer.Types as HCE +import Language.Haskell.Syntax.Extension + ( IdP ) +import Prelude hiding ( id + , span + ) +import System.FilePath ( normalise ) -------------------------------------------------------------------------------- -- Pretty-printing @@ -265,25 +288,26 @@ instanceToText flags ClsInst {..} = T.append "instance " $ T.pack . showSDoc flags $ pprSigmaType (idType is_dfun) instanceDeclToText :: DynFlags -> InstDecl GhcRn -> T.Text -instanceDeclToText flags decl = - case decl of +instanceDeclToText flags decl = case decl of -- Pattern match has inaccessible right hand side -- XInstDecl _ -> "" -- ClsInstD _ (XClsInstDecl _) -> "" - ClsInstD _ ClsInstDecl {..} -> - T.append "instance " (toText flags cid_poly_ty) - DataFamInstD _ di -> - let args = - T.intercalate " " . map (toText flags) . feqn_pats . dfid_eqn $ di - in T.concat - ["data instance ", toText flags (unLoc $ feqn_tycon . dfid_eqn $ di), " ", args] - TyFamInstD _ ti -> - let args = - T.intercalate " " . - map (toText flags) . feqn_pats . tfid_eqn $ - ti - in T.concat - ["type instance ", toText flags $ tyFamInstDeclName ti, " ", args] + ClsInstD _ ClsInstDecl {..} -> + T.append "instance " (toText flags cid_poly_ty) + DataFamInstD _ di -> + let args = + T.intercalate " " . map (toText flags) . feqn_pats . dfid_eqn $ di + in T.concat + [ "data instance " + , toText flags (unLoc $ feqn_tycon . dfid_eqn $ di) + , " " + , args + ] + TyFamInstD _ ti -> + let args = + T.intercalate " " . map (toText flags) . feqn_pats . tfid_eqn $ ti + in T.concat + ["type instance ", toText flags $ tyFamInstDeclName ti, " ", args] nameToText :: Name -> T.Text nameToText = T.pack . unpackFS . occNameFS . nameOccName @@ -291,28 +315,24 @@ nameToText = T.pack . unpackFS . occNameFS . nameOccName tyClDeclPrefix :: TyClDecl a -> T.Text tyClDeclPrefix tyClDecl = let isNewTy :: TyClDecl a -> Bool - isNewTy DataDecl {tcdDataDefn = HsDataDefn {dd_ND = NewType}} = True + isNewTy DataDecl { tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True isNewTy _ = False - in case tyClDecl of - FamDecl {} - | isDataFamilyDecl tyClDecl -> "data family " - | otherwise -> "type family " - SynDecl {} -> "type " - DataDecl {} - | isNewTy tyClDecl -> "newtype " - | otherwise -> "data " - ClassDecl {} -> "class " -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) + in case tyClDecl of + FamDecl{} | isDataFamilyDecl tyClDecl -> "data family " + | otherwise -> "type family " + SynDecl{} -> "type " + DataDecl{} | isNewTy tyClDecl -> "newtype " + | otherwise -> "data " + ClassDecl{} -> "class " XTyClDecl _ -> "" -#endif demangleOccName :: Name -> T.Text demangleOccName name - | isDerivedOccName (nameOccName name) = - let removePrefix :: T.Text -> T.Text + | isDerivedOccName (nameOccName name) + = let removePrefix :: T.Text -> T.Text removePrefix occName - | T.isPrefixOf "$sel:" occName = - fst $ T.breakOn ":" (T.drop 5 occName) + | T.isPrefixOf "$sel:" occName = fst + $ T.breakOn ":" (T.drop 5 occName) | T.isPrefixOf "$W" occName = T.drop 2 occName | T.isPrefixOf "$w" occName = T.drop 2 occName | T.isPrefixOf "$m" occName = T.drop 2 occName @@ -329,58 +349,49 @@ demangleOccName name | T.isPrefixOf "D:" occName = T.drop 2 occName | T.isPrefixOf "$co" occName = T.drop 3 occName | otherwise = occName - in removePrefix $ nameToText name - | otherwise = nameToText name + in removePrefix $ nameToText name + | otherwise + = nameToText name stringBufferToByteString :: StringBuffer -> BS.ByteString stringBufferToByteString (StringBuffer buf len cur) = BSI.fromForeignPtr buf cur len nameSort :: Name -> HCE.NameSort -nameSort n = - if isExternalName n - then HCE.External - else HCE.Internal +nameSort n = if isExternalName n then HCE.External else HCE.Internal occNameNameSpace :: OccName -> HCE.NameSpace -occNameNameSpace n - | isDataConNameSpace (occNameSpace n) = HCE.DataName - | isTvNameSpace (occNameSpace n) = HCE.TvName - | isValNameSpace (occNameSpace n) = HCE.VarName - | otherwise = HCE.TcClsName +occNameNameSpace n | isDataConNameSpace (occNameSpace n) = HCE.DataName + | isTvNameSpace (occNameSpace n) = HCE.TvName + | isValNameSpace (occNameSpace n) = HCE.VarName + | otherwise = HCE.TcClsName -- Two 'Id''s may have different types even though they have the same 'Unique'. identifierKey :: DynFlags -> Id -> T.Text -identifierKey flags id - | isLocalId id = - T.concat - [ T.pack . show . getKey . varUnique $ id - , "_" - , T.pack . show . hash . showSDoc flags . ppr . varType $ id - ] +identifierKey flags id | isLocalId id = T.concat + [ T.pack . show . getKey . varUnique $ id + , "_" + , T.pack . show . hash . showSDoc flags . ppr . varType $ id + ] identifierKey _ id = T.pack . show . getKey . varUnique $ id nameKey :: Name -> T.Text nameKey = T.pack . show . getKey . nameUnique mbIdDetails :: Id -> Maybe HCE.IdDetails -mbIdDetails v - | isId v = - case idDetails v of - VanillaId -> Just HCE.VanillaId - RecSelId {sel_naughty = False} -> Just HCE.RecSelId - RecSelId {sel_naughty = True} -> Just HCE.RecSelIdNaughty - DataConWorkId _ -> Just HCE.DataConWorkId - DataConWrapId _ -> Just HCE.DataConWrapId - ClassOpId _ -> Just HCE.ClassOpId - PrimOpId _ -> Just HCE.PrimOpId - FCallId _ -> Just HCE.FCallId - TickBoxOpId _ -> Just HCE.TickBoxOpId - DFunId _ -> Just HCE.DFunId - CoVarId -> Just HCE.CoVarId -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) - JoinId _ -> Just HCE.JoinId -#endif +mbIdDetails v | isId v = case idDetails v of + VanillaId -> Just HCE.VanillaId + RecSelId { sel_naughty = False } -> Just HCE.RecSelId + RecSelId { sel_naughty = True } -> Just HCE.RecSelIdNaughty + DataConWorkId _ -> Just HCE.DataConWorkId + DataConWrapId _ -> Just HCE.DataConWrapId + ClassOpId _ -> Just HCE.ClassOpId + PrimOpId _ -> Just HCE.PrimOpId + FCallId _ -> Just HCE.FCallId + TickBoxOpId _ -> Just HCE.TickBoxOpId + DFunId _ -> Just HCE.DFunId + CoVarId -> Just HCE.CoVarId + JoinId _ -> Just HCE.JoinId mbIdDetails _ = Nothing -------------------------------------------------------------------------------- @@ -389,73 +400,37 @@ mbIdDetails _ = Nothing hsGroupVals :: HsGroup GhcRn -> [LHsBindLR GhcRn GhcRn] hsGroupVals hsGroup = - filter (isGoodSrcSpan . getLocA) $ - case hs_valds hsGroup of + filter (isGoodSrcSpan . getLocA) $ case hs_valds hsGroup of XValBindsLR (NValBinds binds _) -> concatMap (bagToList . snd) binds - _ -> [] + _ -> [] hsPatSynDetails :: HsPatSynDetails GhcRn -> [Located Name] -hsPatSynDetails patDetails = - case patDetails of - InfixCon name1 name2 -> [reLocN name1, reLocN name2] - PrefixCon _ fields -> reLocN <$> fields - RecCon fields -> concatMap - (\field -> [ - L ((getLocA . rdrNameFieldOcc . recordPatSynField) field) - (extFieldOcc $ recordPatSynField field), - reLocN $ recordPatSynPatVar field]) - fields - -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +hsPatSynDetails patDetails = case patDetails of + InfixCon name1 name2 -> [reLocN name1, reLocN name2] + PrefixCon _ fields -> reLocN <$> fields + RecCon fields -> concatMap + (\field -> + [ L ((getLocA . rdrNameFieldOcc . recordPatSynField) field) + (extFieldOcc $ recordPatSynField field) + , reLocN $ recordPatSynPatVar field + ] + ) + fields + unwrapName :: LIEWrappedName a -> Located a unwrapName = reLocN . ieLWrappedName -#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) -unwrapName :: LIEWrappedName Name -> Located Name -unwrapName = ieLWrappedName -#else -unwrapName :: Located Name -> Located Name -unwrapName n = n -#endif - -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + ieLocNames :: IE pass -> [Located (IdP pass)] -#else -ieLocNames :: IE Name -> [Located Name] -#endif - -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -ieLocNames (XIE _) = [] -ieLocNames (IEVar _ n) = -#else -ieLocNames (IEVar n) = -#endif - [unwrapName n] -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -ieLocNames (IEThingAbs _ n) = -#else -ieLocNames (IEThingAbs n) = -#endif - [unwrapName n] -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -ieLocNames (IEThingAll _ n) = -#else -ieLocNames (IEThingAll n) = -#endif - [unwrapName n] -#if MIN_VERSION_GLASGOW_HASKELL(9,2,1,0) -ieLocNames (IEThingWith _ n _ ns) = - unwrapName n : (map unwrapName ns) -#elif MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -ieLocNames (IEThingWith _ n _ ns labels) = - unwrapName n : (map unwrapName ns ++ map (fmap flSelector) labels) -#else -ieLocNames (IEThingWith n _ ns labels) = - unwrapName n : (map unwrapName ns ++ map (fmap flSelector) labels) -#endif -ieLocNames IEModuleContents {} = [] -ieLocNames IEGroup {} = [] -ieLocNames IEDoc {} = [] -ieLocNames IEDocNamed {} = [] + +ieLocNames (XIE _ ) = [] +ieLocNames (IEVar _ n ) = [unwrapName n] +ieLocNames (IEThingAbs _ n ) = [unwrapName n] +ieLocNames (IEThingAll _ n ) = [unwrapName n] +ieLocNames (IEThingWith _ n _ ns) = unwrapName n : (map unwrapName ns) +ieLocNames IEModuleContents{} = [] +ieLocNames IEGroup{} = [] +ieLocNames IEDoc{} = [] +ieLocNames IEDocNamed{} = [] -------------------------------------------------------------------------------- -- Lookups @@ -463,40 +438,38 @@ ieLocNames IEDocNamed {} = [] lookupIdInTypeEnv :: TypeEnv -> Name -> Maybe Id lookupIdInTypeEnv typeEnv name = do - let mbTyThing - | isInternalName name = Nothing - | isSystemName name = Nothing - | isWiredInName name = wiredInNameTyThing_maybe name - | isExternalName name = lookupTypeEnv typeEnv name - | otherwise = Nothing + let mbTyThing | isInternalName name = Nothing + | isSystemName name = Nothing + | isWiredInName name = wiredInNameTyThing_maybe name + | isExternalName name = lookupTypeEnv typeEnv name + | otherwise = Nothing case mbTyThing of Just tyThing -> tyThingToId tyThing - _ -> Nothing + _ -> Nothing -lookupNameModuleAndPackage :: - UnitState +lookupNameModuleAndPackage + :: UnitState -> HCE.PackageId -> Name -> Either T.Text (HCE.HaskellModuleName, HCE.PackageId) lookupNameModuleAndPackage state currentPackageId name = case nameModule_maybe name of - Just Module {..} -> - case lookupUnit state moduleUnit of - Just unitInfo -> - let packageId = - if (T.pack . unitPackageNameString $ unitInfo) == - HCE.name (currentPackageId :: HCE.PackageId) - then currentPackageId - else HCE.PackageId - (T.pack $ unitPackageNameString unitInfo) - (unitPackageVersion unitInfo) - in Right - ( HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName - , packageId) - Nothing -> - Right - ( HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName - , currentPackageId) + Just Module {..} -> case lookupUnit state moduleUnit of + Just unitInfo -> + let packageId = + if (T.pack . unitPackageNameString $ unitInfo) + == HCE.name (currentPackageId :: HCE.PackageId) + then currentPackageId + else HCE.PackageId (T.pack $ unitPackageNameString unitInfo) + (unitPackageVersion unitInfo) + in Right + ( HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName + , packageId + ) + Nothing -> Right + ( HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName + , currentPackageId + ) Nothing -> Left $ T.concat ["nameModule_maybe ", nameToText name, " is Nothing"] @@ -507,67 +480,68 @@ lookupNameModuleAndPackage state currentPackageId name = isHsBoot :: HCE.HaskellModulePath -> Bool isHsBoot = T.isSuffixOf "-boot" . HCE.getHaskellModulePath -moduleLocationInfo :: - UnitState - -> HM.HashMap HCE.HaskellModuleName (HM.HashMap HCE.ComponentId HCE.HaskellModulePath) +moduleLocationInfo + :: UnitState + -> HM.HashMap + HCE.HaskellModuleName + (HM.HashMap HCE.ComponentId HCE.HaskellModulePath) -> HCE.PackageId -> HCE.ComponentId -> ModuleName -> HCE.LocationInfo moduleLocationInfo unitState moduleNameMap currentPackageId compId moduleName = - let moduleNameText = T.pack . moduleNameString $ moduleName - currentPackageLocation = - HCE.ApproximateLocation - currentPackageId - (HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName) - HCE.Mod - moduleNameText - Nothing - compId - in case HM.lookup (HCE.HaskellModuleName moduleNameText) moduleNameMap of + let moduleNameText = T.pack . moduleNameString $ moduleName + currentPackageLocation = HCE.ApproximateLocation + currentPackageId + (HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName) + HCE.Mod + moduleNameText + Nothing + compId + in case HM.lookup (HCE.HaskellModuleName moduleNameText) moduleNameMap of Just modulePathMap - | Just modulePath <- HM.lookup compId modulePathMap -> - HCE.ExactLocation - currentPackageId - modulePath - (HCE.HaskellModuleName moduleNameText) - 1 - 1 - 1 - 1 - _ -> - case lookupModuleWithSuggestions unitState moduleName Nothing of - LookupFound Module {moduleUnit = unitId} _ -> - case lookupUnit unitState unitId of - Just unitInfo -> - let packageId = - HCE.PackageId - (T.pack $ unitPackageNameString unitInfo) - (unitPackageVersion unitInfo) - in HCE.ApproximateLocation - packageId - (HCE.HaskellModuleName . T.pack . moduleNameString $ - moduleName) - HCE.Mod - moduleNameText - Nothing - (if packageId == currentPackageId - then compId - else HCE.ComponentId "lib") - Nothing -> currentPackageLocation - _ -> currentPackageLocation - -isDefinedInCurrentModule :: - HCE.SourceCodeTransformation -> HCE.HaskellFilePath -> Bool + | Just modulePath <- HM.lookup compId modulePathMap -> HCE.ExactLocation + currentPackageId + modulePath + (HCE.HaskellModuleName moduleNameText) + 1 + 1 + 1 + 1 + _ -> case lookupModuleWithSuggestions unitState moduleName Nothing of + LookupFound Module { moduleUnit = unitId } _ -> + case lookupUnit unitState unitId of + Just unitInfo -> + let packageId = HCE.PackageId + (T.pack $ unitPackageNameString unitInfo) + (unitPackageVersion unitInfo) + in HCE.ApproximateLocation + packageId + ( HCE.HaskellModuleName + . T.pack + . moduleNameString + $ moduleName + ) + HCE.Mod + moduleNameText + Nothing + (if packageId == currentPackageId + then compId + else HCE.ComponentId "lib" + ) + Nothing -> currentPackageLocation + _ -> currentPackageLocation + +isDefinedInCurrentModule + :: HCE.SourceCodeTransformation -> HCE.HaskellFilePath -> Bool isDefinedInCurrentModule transformation file = let includedFiles = HM.keys $ HCE.fileIndex transformation - modPath = - HCE.getHaskellModulePath $ - HCE.filePath (transformation :: HCE.SourceCodeTransformation) - in HCE.getHaskellFilePath file == modPath || (file `elem` includedFiles) + modPath = HCE.getHaskellModulePath + $ HCE.filePath (transformation :: HCE.SourceCodeTransformation) + in HCE.getHaskellFilePath file == modPath || (file `elem` includedFiles) -nameLocationInfo :: - UnitState +nameLocationInfo + :: UnitState -> HCE.PackageId -> HCE.ComponentId -> HCE.SourceCodeTransformation @@ -578,74 +552,76 @@ nameLocationInfo :: -> Name -> HCE.LocationInfo nameLocationInfo unitState currentPackageId compId transformation fileMap defSiteMap mbInstanceHead mbSrcSpan name - | Just srcSpan <- realSrcSpan name mbSrcSpan = - let filePath = - HCE.HaskellFilePath . T.pack . normalise . unpackFS . srcSpanFile $ - srcSpan - approximateLocation = - mkApproximateLocation - unitState - currentPackageId - compId - mbInstanceHead - name - in if isDefinedInCurrentModule transformation filePath - then let eitherStart = - HCE.fromOriginalLineNumber - transformation - (filePath, srcSpanStartLine srcSpan) - eitherEnd = - HCE.fromOriginalLineNumber - transformation - (filePath, srcSpanEndLine srcSpan) - in case (,) eitherStart eitherEnd of - (Right startLine,Right endLine) -> - let modulePath = HCE.filePath (transformation :: HCE.SourceCodeTransformation) - moduleName = - either - (const $ HCE.HaskellModuleName "") - fst - (lookupNameModuleAndPackage unitState currentPackageId name) - in HCE.ExactLocation - { packageId = currentPackageId - , modulePath = modulePath - , moduleName = moduleName - , startLine = startLine - , endLine = endLine - , startColumn = srcSpanStartCol srcSpan - , endColumn = srcSpanEndCol srcSpan - } - _ -> approximateLocation - else case HM.lookup filePath fileMap of - Just haskellModulePath -> - case HM.lookup haskellModulePath defSiteMap of - Just defSites -> - let key = fromMaybe (nameToText name) mbInstanceHead - in lookupEntityLocation - defSites - (mkLocatableEntity name mbInstanceHead) - key - Nothing -> approximateLocation - Nothing -> approximateLocation - where - realSrcSpan :: Name -> Maybe SrcSpan -> Maybe RealSrcSpan - realSrcSpan n mbSpan = - case nameSrcSpan n of - RealSrcSpan span _ -> Just span - _ - | isWiredInName n -> - case mbSpan of - Just span -> - case span of - RealSrcSpan s _ -> Just s - _ -> Nothing - _ -> Nothing - _ -> Nothing -nameLocationInfo unitState currentPackageId compId _transformation _fileMap _defSiteMap mbInstanceHead _mbSrcSpan name = - mkApproximateLocation unitState currentPackageId compId mbInstanceHead name + | Just srcSpan <- realSrcSpan name mbSrcSpan + = let + filePath = + HCE.HaskellFilePath + . T.pack + . normalise + . unpackFS + . srcSpanFile + $ srcSpan + approximateLocation = mkApproximateLocation unitState + currentPackageId + compId + mbInstanceHead + name + in + if isDefinedInCurrentModule transformation filePath + then + let + eitherStart = HCE.fromOriginalLineNumber + transformation + (filePath, srcSpanStartLine srcSpan) + eitherEnd = HCE.fromOriginalLineNumber + transformation + (filePath, srcSpanEndLine srcSpan) + in + case (,) eitherStart eitherEnd of + (Right startLine, Right endLine) -> + let + modulePath = HCE.filePath + (transformation :: HCE.SourceCodeTransformation) + moduleName = either + (const $ HCE.HaskellModuleName "") + fst + (lookupNameModuleAndPackage unitState currentPackageId name) + in + HCE.ExactLocation { packageId = currentPackageId + , modulePath = modulePath + , moduleName = moduleName + , startLine = startLine + , endLine = endLine + , startColumn = srcSpanStartCol srcSpan + , endColumn = srcSpanEndCol srcSpan + } + _ -> approximateLocation + else case HM.lookup filePath fileMap of + Just haskellModulePath -> + case HM.lookup haskellModulePath defSiteMap of + Just defSites -> + let key = fromMaybe (nameToText name) mbInstanceHead + in lookupEntityLocation + defSites + (mkLocatableEntity name mbInstanceHead) + key + Nothing -> approximateLocation + Nothing -> approximateLocation + where + realSrcSpan :: Name -> Maybe SrcSpan -> Maybe RealSrcSpan + realSrcSpan n mbSpan = case nameSrcSpan n of + RealSrcSpan span _ -> Just span + _ | isWiredInName n -> case mbSpan of + Just span -> case span of + RealSrcSpan s _ -> Just s + _ -> Nothing + _ -> Nothing + _ -> Nothing +nameLocationInfo unitState currentPackageId compId _transformation _fileMap _defSiteMap mbInstanceHead _mbSrcSpan name + = mkApproximateLocation unitState currentPackageId compId mbInstanceHead name -mkApproximateLocation :: - UnitState +mkApproximateLocation + :: UnitState -> HCE.PackageId -> HCE.ComponentId -> Maybe T.Text @@ -654,78 +630,70 @@ mkApproximateLocation :: mkApproximateLocation unitState currentPackageId compId mbInstanceHead name = let haddockAnchor = Just . T.pack . makeAnchorId . T.unpack . nameToText $ name - in case lookupNameModuleAndPackage unitState currentPackageId name of - Right (moduleName, packageId) -> - HCE.ApproximateLocation - { moduleName = moduleName - , packageId = packageId - , componentId = - if packageId == currentPackageId - then compId - else HCE.ComponentId "lib" - , entity = mkLocatableEntity name mbInstanceHead - , haddockAnchorId = haddockAnchor - , name = fromMaybe (nameToText name) mbInstanceHead - } + in case lookupNameModuleAndPackage unitState currentPackageId name of + Right (moduleName, packageId) -> HCE.ApproximateLocation + { moduleName = moduleName + , packageId = packageId + , componentId = if packageId == currentPackageId + then compId + else HCE.ComponentId "lib" + , entity = mkLocatableEntity name mbInstanceHead + , haddockAnchorId = haddockAnchor + , name = fromMaybe (nameToText name) mbInstanceHead + } Left errorMessage -> HCE.UnknownLocation errorMessage mkLocatableEntity :: Name -> Maybe a -> HCE.LocatableEntity mkLocatableEntity name mbInstanceHead | isJust mbInstanceHead = HCE.Inst - | otherwise = - case occNameNameSpace . nameOccName $ name of - HCE.VarName -> HCE.Val - HCE.DataName -> HCE.Val - _ -> HCE.Typ - -occNameLocationInfo :: - DynFlags + | otherwise = case occNameNameSpace . nameOccName $ name of + HCE.VarName -> HCE.Val + HCE.DataName -> HCE.Val + _ -> HCE.Typ + +occNameLocationInfo + :: DynFlags -> HCE.PackageId -> HCE.ComponentId -> (ModuleName, OccName) -> HCE.LocationInfo occNameLocationInfo flags packageId componentId (modName, occName) = HCE.ApproximateLocation - { packageId = packageId - , moduleName = HCE.HaskellModuleName $ toText flags modName - , entity = - case occNameNameSpace occName of - HCE.VarName -> HCE.Val - HCE.DataName -> HCE.Val - _ -> HCE.Typ - , name = toText flags occName - , haddockAnchorId = - Just . T.pack . makeAnchorId . T.unpack $ toText flags occName - , componentId = componentId + { packageId = packageId + , moduleName = HCE.HaskellModuleName $ toText flags modName + , entity = case occNameNameSpace occName of + HCE.VarName -> HCE.Val + HCE.DataName -> HCE.Val + _ -> HCE.Typ + , name = toText flags occName + , haddockAnchorId = Just . T.pack . makeAnchorId . T.unpack $ toText + flags + occName + , componentId = componentId } -lookupEntityLocation :: - HCE.DefinitionSiteMap -> HCE.LocatableEntity -> T.Text -> HCE.LocationInfo +lookupEntityLocation + :: HCE.DefinitionSiteMap -> HCE.LocatableEntity -> T.Text -> HCE.LocationInfo lookupEntityLocation defSiteMap locatableEntity text = - let errorMessage = - T.concat - [ "Cannot find location of " - , T.pack . show $ locatableEntity - , " " - , text - ] + let errorMessage = T.concat + ["Cannot find location of ", T.pack . show $ locatableEntity, " ", text] defSiteLocation = HCE.location :: HCE.DefinitionSite -> HCE.LocationInfo - lookupLocation :: - (Eq a, Hashable a) + lookupLocation + :: (Eq a, Hashable a) => (HCE.DefinitionSiteMap -> HM.HashMap a HCE.DefinitionSite) -> (T.Text -> a) -> HCE.LocationInfo lookupLocation selector toKey = - maybe (HCE.UnknownLocation errorMessage) defSiteLocation $ - HM.lookup (toKey text) (selector defSiteMap) - in case locatableEntity of - HCE.Val -> lookupLocation HCE.values HCE.OccName - HCE.Typ -> lookupLocation HCE.types HCE.OccName + maybe (HCE.UnknownLocation errorMessage) defSiteLocation + $ HM.lookup (toKey text) (selector defSiteMap) + in case locatableEntity of + HCE.Val -> lookupLocation HCE.values HCE.OccName + HCE.Typ -> lookupLocation HCE.types HCE.OccName HCE.Inst -> lookupLocation HCE.instances (\t -> t) - HCE.Mod -> HCE.UnknownLocation errorMessage + HCE.Mod -> HCE.UnknownLocation errorMessage -nameDocumentation :: - HCE.SourceCodeTransformation +nameDocumentation + :: HCE.SourceCodeTransformation -> HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath -> HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap -> HCE.DefinitionSiteMap @@ -733,38 +701,36 @@ nameDocumentation :: -> Maybe T.Text nameDocumentation transformation fileMap defSiteMap currentModuleDefSiteMap name | isExternalName name || isWiredInName name - , Just file <- srcSpanToFilePath . nameSrcSpan $ name = - if isDefinedInCurrentModule transformation file - then lookupNameDocumentation name currentModuleDefSiteMap - else case HM.lookup file fileMap of - Just haskellModulePath -> - case HM.lookup haskellModulePath defSiteMap of - Just defSites -> lookupNameDocumentation name defSites - Nothing -> Nothing - Nothing -> Nothing + , Just file <- srcSpanToFilePath . nameSrcSpan $ name + = if isDefinedInCurrentModule transformation file + then lookupNameDocumentation name currentModuleDefSiteMap + else case HM.lookup file fileMap of + Just haskellModulePath -> case HM.lookup haskellModulePath defSiteMap of + Just defSites -> lookupNameDocumentation name defSites + Nothing -> Nothing + Nothing -> Nothing nameDocumentation _ _ _ _ _ = Nothing lookupNameDocumentation :: Name -> HCE.DefinitionSiteMap -> Maybe T.Text lookupNameDocumentation name defSiteMap = let key = HCE.OccName $ nameToText name - lookupDoc :: - (HCE.DefinitionSiteMap -> HM.HashMap HCE.OccName HCE.DefinitionSite) + lookupDoc + :: (HCE.DefinitionSiteMap -> HM.HashMap HCE.OccName HCE.DefinitionSite) -> Maybe T.Text - lookupDoc selector = - maybe Nothing HCE.documentation $ - HM.lookup key (selector (defSiteMap :: HCE.DefinitionSiteMap)) - in case occNameNameSpace . nameOccName $ name of - HCE.VarName -> lookupDoc HCE.values + lookupDoc selector = maybe Nothing HCE.documentation + $ HM.lookup key (selector (defSiteMap :: HCE.DefinitionSiteMap)) + in case occNameNameSpace . nameOccName $ name of + HCE.VarName -> lookupDoc HCE.values HCE.DataName -> lookupDoc HCE.values - _ -> lookupDoc HCE.types + _ -> lookupDoc HCE.types srcSpanToFilePath :: SrcSpan -> Maybe HCE.HaskellFilePath srcSpanToFilePath (RealSrcSpan s _) = Just . HCE.HaskellFilePath . T.pack . normalise . unpackFS . srcSpanFile $ s srcSpanToFilePath (UnhelpfulSpan _) = Nothing -srcSpanToLineAndColNumbers :: - HCE.SourceCodeTransformation +srcSpanToLineAndColNumbers + :: HCE.SourceCodeTransformation -> SrcSpan -> Maybe (HCE.HaskellFilePath, (Int, Int), (Int, Int)) -- do we need to do anything with the BufSpan? @@ -775,12 +741,13 @@ srcSpanToLineAndColNumbers transformation (RealSrcSpan s _) = HCE.fromOriginalLineNumber transformation (filePath, srcSpanStartLine s) eitherEnd = HCE.fromOriginalLineNumber transformation (filePath, srcSpanEndLine s) - in case (,) eitherStart eitherEnd of + in case (,) eitherStart eitherEnd of (Right startLine, Right endLine) -> Just ( filePath , (startLine, srcSpanStartCol s) - , (endLine, srcSpanEndCol s)) + , (endLine , srcSpanEndCol s) + ) _ -> Nothing srcSpanToLineAndColNumbers _ _ = Nothing @@ -789,20 +756,18 @@ srcSpanToLineAndColNumbers _ _ = Nothing -------------------------------------------------------------------------------- tyThingToId :: TyThing -> Maybe Id -tyThingToId tyThing = - case tyThing of - AnId id -> Just id - ATyCon tc -> Just $ mkTyVar (tyConName tc) (tyConKind tc) - AConLike con -> - case con of - RealDataCon dataCon -> Just $ dataConWorkId dataCon - PatSynCon ps -> Just $ patSynId ps - ACoAxiom _ -> Nothing +tyThingToId tyThing = case tyThing of + AnId id -> Just id + ATyCon tc -> Just $ mkTyVar (tyConName tc) (tyConKind tc) + AConLike con -> case con of + RealDataCon dataCon -> Just $ dataConWorkId dataCon + PatSynCon ps -> Just $ patSynId ps + ACoAxiom _ -> Nothing tidyIdentifierType :: TidyEnv -> Id -> (TidyEnv, Id) tidyIdentifierType tidyEnv identifier = let (tidyEnv', typ') = tidyOpenType tidyEnv (varType identifier) - in (tidyEnv', setVarType identifier typ') + in (tidyEnv', setVarType identifier typ') patSynId :: PatSyn -> Id patSynId patSyn = @@ -812,72 +777,67 @@ patSynId patSyn = | otherwise = reqTheta -- required => provided => arg_1 -> ... -> arg_n -> res patSynTy = - mkTyCoInvForAllTys univTvs $ - mkVisFunTysMany reqTheta' $ - mkTyCoInvForAllTys exTvs $ mkVisFunTysMany provTheta $ mkVisFunTys argTys resTy + mkTyCoInvForAllTys univTvs + $ mkVisFunTysMany reqTheta' + $ mkTyCoInvForAllTys exTvs + $ mkVisFunTysMany provTheta + $ mkVisFunTys argTys resTy (name, _, _) = patSynMatcher patSyn - in mkCoVar name patSynTy + in mkCoVar name patSynTy applyWrapper :: HsWrapper -> Type -> Type -applyWrapper wp ty - | Just ty' <- coreView ty = applyWrapper wp ty' -applyWrapper WpHole t = t +applyWrapper wp ty | Just ty' <- coreView ty = applyWrapper wp ty' +applyWrapper WpHole t = t applyWrapper (WpCompose w1 w2) t = applyWrapper w1 . applyWrapper w2 $ t -applyWrapper (WpFun w1 w2 t1 _doc) t = - mkVisFunTys [t1] (applyWrapper w2 $ piResultTy t - (applyWrapper w1 $ scaledThing t1)) -applyWrapper (WpCast coercion) _t = pSnd $ tcCoercionKind coercion -applyWrapper (WpEvLam v) t = mkVisFunTyMany (evVarPred v) t -applyWrapper (WpEvApp _ev) t = case splitFunTy_maybe t of - Just (_, _arg,res) -> res - Nothing -> t -applyWrapper (WpTyLam v) t = mkForAllTy v Required t -applyWrapper (WpTyApp t') t = piResultTy t t' -applyWrapper (WpLet _) t = t +applyWrapper (WpFun w1 w2 t1 _doc) t = mkVisFunTys + [t1] + (applyWrapper w2 $ piResultTy t (applyWrapper w1 $ scaledThing t1)) +applyWrapper (WpCast coercion) _t = pSnd $ tcCoercionKind coercion +applyWrapper (WpEvLam v ) t = mkVisFunTyMany (evVarPred v) t +applyWrapper (WpEvApp _ev ) t = case splitFunTy_maybe t of + Just (_, _arg, res) -> res + Nothing -> t +applyWrapper (WpTyLam v ) t = mkForAllTy v Required t +applyWrapper (WpTyApp t' ) t = piResultTy t t' +applyWrapper (WpLet _ ) t = t applyWrapper (WpMultCoercion coercion) _ = pSnd $ tcCoercionKind coercion wrapperTypes :: HsWrapper -> [Type] -wrapperTypes WpHole = [] -wrapperTypes (WpCompose w1 w2) = wrapperTypes w2 ++ wrapperTypes w1 -wrapperTypes (WpFun w1 w2 _ _) = wrapperTypes w2 ++ wrapperTypes w1 -wrapperTypes (WpCast _) = [] -wrapperTypes (WpEvLam _) = [] -wrapperTypes (WpEvApp _) = [] -wrapperTypes (WpTyLam _) = [] -wrapperTypes (WpTyApp t) = [t] -wrapperTypes (WpLet _) = [] +wrapperTypes WpHole = [] +wrapperTypes (WpCompose w1 w2 ) = wrapperTypes w2 ++ wrapperTypes w1 +wrapperTypes (WpFun w1 w2 _ _ ) = wrapperTypes w2 ++ wrapperTypes w1 +wrapperTypes (WpCast _) = [] +wrapperTypes (WpEvLam _) = [] +wrapperTypes (WpEvApp _) = [] +wrapperTypes (WpTyLam _) = [] +wrapperTypes (WpTyApp t) = [t] +wrapperTypes (WpLet _) = [] wrapperTypes (WpMultCoercion _) = [] mkType :: DynFlags -> Type -> HCE.Type mkType flags typ = - let typeExpanded = expandTypeSynonyms typ - typeComponents = toTypeComponents flags typ + let typeExpanded = expandTypeSynonyms typ + typeComponents = toTypeComponents flags typ typeComponentsExpanded = toTypeComponents flags typeExpanded - in HCE.Type + in HCE.Type typeComponents (if typeComponents /= typeComponentsExpanded - then Just typeComponentsExpanded - else Nothing) + then Just typeComponentsExpanded + else Nothing + ) -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) typeToText :: DynFlags -> Type -> T.Text typeToText flags = T.pack . showSDoc flags . pprIfaceType . toIfaceType -#else -typeToText :: DynFlags -> Type -> T.Text -typeToText = toText -#endif toTypeComponents :: DynFlags -> Type -> [HCE.TypeComponent] toTypeComponents flags typ = - let signature = - typeToText flags $ - updateOccNames (\_unique occName -> ";" ++ drop 2 occName ++ ";") typ + let signature = typeToText flags $ updateOccNames + (\_unique occName -> ";" ++ drop 2 occName ++ ";") + typ -- Signature with OccNames and uniques - signatureWithUniques = - typeToText flags $ - updateOccNames - (\unique occName -> ";," ++ occName ++ "," ++ unique ++ ";") - typ + signatureWithUniques = typeToText flags $ updateOccNames + (\unique occName -> ";," ++ occName ++ "," ++ unique ++ ";") + typ -- Dirty but simple way to extract a list of TypeComponent from a type signature. -- Assumptions : -- 1. Character ';' cannot appear anywhere in a type signature @@ -885,60 +845,51 @@ toTypeComponents flags typ = -- 3. length (T.splitOn ";" signature) == length (T.splitOn ";" signatureWithUniques) components = L.zip (T.splitOn ";" signature) (T.splitOn ";" signatureWithUniques) - in mapMaybe - (\(text1, text2) -> - if T.isPrefixOf "," text2 - then case T.splitOn "," text2 of - ["", name, id] -> - Just HCE.TyCon {name = name, internalId = HCE.InternalId id} - _ -> Just $ HCE.Text text1 - else if T.null text1 - then Nothing - else Just $ HCE.Text text1) + in mapMaybe + (\(text1, text2) -> if T.isPrefixOf "," text2 + then case T.splitOn "," text2 of + ["", name, id] -> + Just HCE.TyCon { name = name, internalId = HCE.InternalId id } + _ -> Just $ HCE.Text text1 + else if T.null text1 then Nothing else Just $ HCE.Text text1 + ) components -- | Replaces 'OccName' of each type variable and type constructor in a type. updateOccNames :: (String -> String -> String) -> Type -> Type updateOccNames update = everywhere (mkT updateType) - where - updateType :: Type -> Type - updateType (TyVarTy var) = TyVarTy var {varName = updateName (varName var)} - updateType (TyConApp con args) = - TyConApp (con {tyConName = updateName (tyConName con)}) args - updateType other = other - updateName :: Name -> Name - updateName oldName = - let oldOccName = nameOccName oldName - unique = T.unpack $ nameKey oldName - newOccName = - mkOccName - (occNameSpace oldOccName) - (update unique (occNameString oldOccName)) - in mkInternalName (nameUnique oldName) newOccName (nameSrcSpan oldName) + where + updateType :: Type -> Type + updateType (TyVarTy var) = TyVarTy var { varName = updateName (varName var) } + updateType (TyConApp con args) = + TyConApp (con { tyConName = updateName (tyConName con) }) args + updateType other = other + updateName :: Name -> Name + updateName oldName = + let + oldOccName = nameOccName oldName + unique = T.unpack $ nameKey oldName + newOccName = mkOccName (occNameSpace oldOccName) + (update unique (occNameString oldOccName)) + in + mkInternalName (nameUnique oldName) newOccName (nameSrcSpan oldName) -- | This function doesn't look through type synonyms tyConsOfType :: Type -> [Id] -tyConsOfType = -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) - nonDetEltsUniqSet . everything unionUniqSets (emptyVarSet `mkQ` tyCon) -#else - uniqSetToList . everything unionUniqSets (emptyVarSet `mkQ` tyCon) -#endif - where - tyCon :: Type -> VarSet - tyCon (TyConApp tc _) = unitVarSet $ mkTyVar (tyConName tc) (tyConKind tc) - tyCon _ = emptyUniqSet +tyConsOfType = nonDetEltsUniqSet + . everything unionUniqSets (emptyVarSet `mkQ` tyCon) + where + tyCon :: Type -> VarSet + tyCon (TyConApp tc _) = unitVarSet $ mkTyVar (tyConName tc) (tyConKind tc) + tyCon _ = emptyUniqSet tyVarsOfType :: (Data a) => a -> [Id] -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) -tyVarsOfType = nonDetEltsUniqSet . everything unionVarSet (emptyVarSet `mkQ` tyVar) -#else -tyVarsOfType = varSetElems . everything unionVarSet (emptyVarSet `mkQ` tyVar) -#endif - where - tyVar :: Type -> VarSet - tyVar (TyVarTy ty) = unitVarSet ty - tyVar _ = emptyVarSet +tyVarsOfType = nonDetEltsUniqSet + . everything unionVarSet (emptyVarSet `mkQ` tyVar) + where + tyVar :: Type -> VarSet + tyVar (TyVarTy ty) = unitVarSet ty + tyVar _ = emptyVarSet -------------------------------------------------------------------------------- -- Documentation processing @@ -953,187 +904,153 @@ tyVarsOfType = varSetElems . everything unionVarSet (emptyVarSet `mkQ` tyVar) classDeclDocs :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] classDeclDocs class_ = collectDocs . sortLocatedA $ decls - where - decls = docs ++ defs ++ sigs ++ ats - docs = mkDecls tcdDocs (DocD NoExtField) class_ - defs = mkDecls (bagToList . tcdMeths) (ValD NoExtField) class_ - sigs = mkDecls tcdSigs (SigD NoExtField) class_ - ats = mkDecls tcdATs ((TyClD NoExtField) . (FamDecl NoExtField)) class_ + where + decls = docs ++ defs ++ sigs ++ ats + docs = mkDecls tcdDocs (DocD NoExtField) class_ + defs = mkDecls (bagToList . tcdMeths) (ValD NoExtField) class_ + sigs = mkDecls tcdSigs (SigD NoExtField) class_ + ats = mkDecls tcdATs ((TyClD NoExtField) . (FamDecl NoExtField)) class_ conDeclDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)] conDeclDocs conDecl = - map (\con -> (unLoc con, maybe [] ((: []) . unLoc) $ con_doc conDecl, getLocA con)) . - getConNames $ - conDecl + map + (\con -> + (unLoc con, maybe [] ((: []) . unLoc) $ con_doc conDecl, getLocA con) + ) + . getConNames + $ conDecl selectorDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)] -selectorDocs con = - case getRecConArgs_maybe con of - Just (L _ flds) -> +selectorDocs con = case getRecConArgs_maybe con of + Just (L _ flds) -> concatMap + (\(L _ (ConDeclField _ fieldOccs _ mbDoc)) -> map + (\(L span f) -> (extFieldOcc f, maybe [] ((: []) . unLoc) mbDoc, span)) + fieldOccs + ) + flds + _ -> [] + +subordinateNamesWithDocs :: [LHsDecl GhcRn] -> [(Name, [HsDocString], SrcSpan)] +subordinateNamesWithDocs = concatMap + (\lhd -> case unLoc lhd of + TyClD _ classDecl@ClassDecl{} -> concatMap - (\(L _ (ConDeclField _ fieldOccs _ mbDoc)) -> - map - (\(L span f) -> - (extFieldOcc f, maybe [] ((: []) . unLoc) mbDoc, span)) - fieldOccs) - flds + (\(L _ decl, docs) -> + map (, docs, getLocA lhd) $ getMainDeclBinder decl + ) + $ classDeclDocs classDecl + TyClD _ DataDecl {..} -> + concatMap (\(L _ con) -> conDeclDocs con ++ selectorDocs con) + $ dd_cons tcdDataDefn + InstD _ (DataFamInstD _ DataFamInstDecl {..}) -> + concatMap (conDeclDocs . unLoc) . dd_cons . feqn_rhs $ dfid_eqn _ -> [] + ) + -subordinateNamesWithDocs :: [LHsDecl GhcRn] -> [(Name, [HsDocString], SrcSpan)] -subordinateNamesWithDocs = - concatMap - (\lhd -> - case unLoc lhd of - TyClD _ classDecl@ClassDecl {} -> - concatMap - (\(L _ decl, docs) -> map (, docs, getLocA lhd) $ getMainDeclBinder decl) $ - classDeclDocs classDecl - TyClD _ DataDecl {..} -> - concatMap (\(L _ con) -> conDeclDocs con ++ selectorDocs con) $ - dd_cons tcdDataDefn - InstD _ (DataFamInstD _ DataFamInstDecl {..}) -> - concatMap (conDeclDocs . unLoc) . dd_cons . feqn_rhs $ dfid_eqn - _ -> []) - - -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) getMainDeclBinder :: HsDecl GhcRn -> [IdP GhcRn] -#else -getMainDeclBinder :: HsDecl name -> [name] -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -getMainDeclBinder (TyClD _ d) = -#else -getMainDeclBinder (TyClD d) = -#endif - [tcdName d] -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -getMainDeclBinder (ValD _ d) = -#else -getMainDeclBinder (ValD d) = -#endif - case collectHsBindBinders CollNoDictBinders d of - [] -> [] - (name:_) -> [name] -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) +getMainDeclBinder (TyClD _ d) = [tcdName d] +getMainDeclBinder (ValD _ d) = case collectHsBindBinders CollNoDictBinders d of + [] -> [] + (name : _) -> [name] getMainDeclBinder (SigD _ d) = sigNameNoLoc d -#else -getMainDeclBinder (SigD d) = sigNameNoLoc d -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] -#else -getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -getMainDeclBinder (ForD _ ForeignExport {}) = [] -#else -getMainDeclBinder (ForD ForeignExport {}) = [] -#endif +getMainDeclBinder (ForD _ ForeignExport{}) = [] getMainDeclBinder _ = [] -sigNameNoLoc :: forall p. UnXRec p => Sig p -> [IdP p] -sigNameNoLoc (TypeSig _ ns _) = map (unXRec @p) ns -sigNameNoLoc (ClassOpSig _ _ ns _) = map (unXRec @p) ns -sigNameNoLoc (PatSynSig _ ns _) = map (unXRec @p) ns -sigNameNoLoc (SpecSig _ n _ _) = [unXRec @p n] -sigNameNoLoc (InlineSig _ n _) = [unXRec @p n] +sigNameNoLoc :: forall p . UnXRec p => Sig p -> [IdP p] +sigNameNoLoc (TypeSig _ ns _ ) = map (unXRec @p) ns +sigNameNoLoc (ClassOpSig _ _ ns _ ) = map (unXRec @p) ns +sigNameNoLoc (PatSynSig _ ns _ ) = map (unXRec @p) ns +sigNameNoLoc (SpecSig _ n _ _ ) = [unXRec @p n] +sigNameNoLoc (InlineSig _ n _ ) = [unXRec @p n] sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map (unXRec @p) ns -sigNameNoLoc _ = [] +sigNameNoLoc _ = [] clsInstDeclSrcSpan :: ClsInstDecl (GhcPass p) -> SrcSpan -clsInstDeclSrcSpan ClsInstDecl {cid_poly_ty = ty} = getLocA ty +clsInstDeclSrcSpan ClsInstDecl { cid_poly_ty = ty } = getLocA ty hsDocsToDocH :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Doc Name hsDocsToDocH flags rdrEnv = - rename flags rdrEnv . - overIdentifier (parseIdent flags) . - _doc -#if MIN_VERSION_haddock_library(1,6,0) + rename flags rdrEnv + . overIdentifier (parseIdent flags) + . _doc . parseParas Nothing -#else - . parseParas -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) . concatMap unpackHDS -#else - . concatMap (unpackFS . (\(HsDocString s) -> s)) -#endif parseIdent :: DynFlags -> Namespace -> String -> Maybe RdrName parseIdent dflags _ str0 = - let buffer = stringToStringBuffer str0 + let buffer = stringToStringBuffer str0 realSrcLc = mkRealSrcLoc (mkFastString "<unknown file>") 0 0 - pstate = initParserState (initParserOpts dflags) buffer realSrcLc - in case unP parseIdentifier pstate of - POk _ name -> Just (unLoc name) - _ -> Nothing + pstate = initParserState (initParserOpts dflags) buffer realSrcLc + in case unP parseIdentifier pstate of + POk _ name -> Just (unLoc name) + _ -> Nothing type Doc id = DocH (ModuleName, OccName) id rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name rename dflags gre = rn - where - rn :: Doc RdrName -> Doc Name - rn d = case d of - DocAppend a b -> DocAppend (rn a) (rn b) - DocParagraph doc -> DocParagraph (rn doc) - DocIdentifier x -> do - -- Generate the choices for the possible kind of thing this - -- is. - let choices = dataTcOccs x - -- Try to look up all the names in the GlobalRdrEnv that match - -- the names. - let names = concatMap (\c -> map grePrintableName (lookupGRE_RdrName c gre)) choices - - case names of - -- We found no names in the env so we start guessing. - [] -> - case choices of - [] -> DocMonospaced (DocString (showPpr dflags x)) - -- There was nothing in the environment so we need to - -- pick some default from what's available to us. We - -- diverge here from the old way where we would default - -- to type constructors as we're much more likely to - -- actually want anchors to regular definitions than - -- type constructor names (such as in #253). So now we - -- only get type constructor links if they are actually - -- in scope. - a:_ -> outOfScope dflags a - - -- There is only one name in the environment that matches so - -- use it. - [a] -> DocIdentifier a - -- But when there are multiple names available, default to - -- type constructors: somewhat awfully GHC returns the - -- values in the list positionally. - a:b:_ | isTyConName a -> DocIdentifier a - | otherwise -> DocIdentifier b - - DocWarning doc -> DocWarning (rn doc) - DocEmphasis doc -> DocEmphasis (rn doc) - DocBold doc -> DocBold (rn doc) - DocMonospaced doc -> DocMonospaced (rn doc) - DocUnorderedList docs -> DocUnorderedList (map rn docs) - DocOrderedList docs -> DocOrderedList (map rn docs) - DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ] - DocCodeBlock doc -> DocCodeBlock (rn doc) - DocIdentifierUnchecked x -> DocIdentifierUnchecked x - DocModule modLink -> DocModule (rn <$> modLink) - DocHyperlink hyperLink -> DocHyperlink (rn <$> hyperLink) - DocPic str -> DocPic str - DocMathInline str -> DocMathInline str - DocMathDisplay str -> DocMathDisplay str - DocAName str -> DocAName str - DocProperty p -> DocProperty p - DocExamples e -> DocExamples e - DocEmpty -> DocEmpty - DocString str -> DocString str - DocHeader (Header l t) -> DocHeader $ Header l (rn t) -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) - DocTable t -> DocTable (rn <$> t) -#endif + where + rn :: Doc RdrName -> Doc Name + rn d = case d of + DocAppend a b -> DocAppend (rn a) (rn b) + DocParagraph doc -> DocParagraph (rn doc) + DocIdentifier x -> do + -- Generate the choices for the possible kind of thing this + -- is. + let choices = dataTcOccs x + -- Try to look up all the names in the GlobalRdrEnv that match + -- the names. + let names = concatMap + (\c -> map grePrintableName (lookupGRE_RdrName c gre)) + choices + + case names of + -- We found no names in the env so we start guessing. + [] -> case choices of + [] -> DocMonospaced (DocString (showPpr dflags x)) + -- There was nothing in the environment so we need to + -- pick some default from what's available to us. We + -- diverge here from the old way where we would default + -- to type constructors as we're much more likely to + -- actually want anchors to regular definitions than + -- type constructor names (such as in #253). So now we + -- only get type constructor links if they are actually + -- in scope. + a : _ -> outOfScope dflags a + + -- There is only one name in the environment that matches so + -- use it. + [a] -> DocIdentifier a + -- But when there are multiple names available, default to + -- type constructors: somewhat awfully GHC returns the + -- values in the list positionally. + a : b : _ | isTyConName a -> DocIdentifier a + | otherwise -> DocIdentifier b + + DocWarning doc -> DocWarning (rn doc) + DocEmphasis doc -> DocEmphasis (rn doc) + DocBold doc -> DocBold (rn doc) + DocMonospaced doc -> DocMonospaced (rn doc) + DocUnorderedList docs -> DocUnorderedList (map rn docs) + DocOrderedList docs -> DocOrderedList (map rn docs) + DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ] + DocCodeBlock doc -> DocCodeBlock (rn doc) + DocIdentifierUnchecked x -> DocIdentifierUnchecked x + DocModule modLink -> DocModule (rn <$> modLink) + DocHyperlink hyperLink -> DocHyperlink (rn <$> hyperLink) + DocPic str -> DocPic str + DocMathInline str -> DocMathInline str + DocMathDisplay str -> DocMathDisplay str + DocAName str -> DocAName str + DocProperty p -> DocProperty p + DocExamples e -> DocExamples e + DocEmpty -> DocEmpty + DocString str -> DocString str + DocHeader (Header l t) -> DocHeader $ Header l (rn t) + DocTable t -> DocTable (rn <$> t) -- | Wrap an identifier that's out of scope (i.e. wasn't found in -- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently @@ -1144,26 +1061,25 @@ rename dflags gre = rn -- #253 and #375 on the confusion this causes depending on which -- default we pick in 'rename'. outOfScope :: DynFlags -> RdrName -> Doc a -outOfScope dflags x = - case x of - Unqual occ -> monospaced occ - Qual mdl occ -> DocIdentifierUnchecked (mdl, occ) - Orig _ occ -> monospaced occ - Exact name -> monospaced name -- Shouldn't happen since x is out of scope - where - monospaced :: (Outputable a) => a -> Doc b - monospaced a = DocMonospaced (DocString (showPpr dflags a)) +outOfScope dflags x = case x of + Unqual occ -> monospaced occ + Qual mdl occ -> DocIdentifierUnchecked (mdl, occ) + Orig _ occ -> monospaced occ + Exact name -> monospaced name -- Shouldn't happen since x is out of scope + where + monospaced :: (Outputable a) => a -> Doc b + monospaced a = DocMonospaced (DocString (showPpr dflags a)) makeAnchorId :: String -> String -makeAnchorId [] = [] -makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r - where - escape p c | p c = [c] - | otherwise = '-' : show (ord c) ++ "-" - isLegal ':' = True - isLegal '_' = True - isLegal '.' = True - isLegal c = isAscii c && isAlphaNum c +makeAnchorId [] = [] +makeAnchorId (f : r) = escape isAlpha f ++ concatMap (escape isLegal) r + where + escape p c | p c = [c] + | otherwise = '-' : show (ord c) ++ "-" + isLegal ':' = True + isLegal '_' = True + isLegal '.' = True + isLegal c = isAscii c && isAlphaNum c ghcDL :: GHC.Located a -> GHC.Located a ghcDL x = x |