diff options
| -rw-r--r-- | src/HaskellCodeExplorer/AST/RenamedSource.hs | 6 | ||||
| -rw-r--r-- | src/HaskellCodeExplorer/AST/TypecheckedSource.hs | 161 | ||||
| -rw-r--r-- | src/HaskellCodeExplorer/GhcUtils.hs | 152 |
3 files changed, 35 insertions, 284 deletions
diff --git a/src/HaskellCodeExplorer/AST/RenamedSource.hs b/src/HaskellCodeExplorer/AST/RenamedSource.hs index 89c84ac..49070c8 100644 --- a/src/HaskellCodeExplorer/AST/RenamedSource.hs +++ b/src/HaskellCodeExplorer/AST/RenamedSource.hs @@ -10,9 +10,7 @@ module HaskellCodeExplorer.AST.RenamedSource , namesFromRenamedSource ) where --- import BasicTypes (TupleSort(..)) import GHC.Types.Basic (TupleSort(..)) --- import BooleanFormula (BooleanFormula(..)) import GHC.Data.BooleanFormula (BooleanFormula(..)) import Data.Generics (Data, everything, extQ, mkQ) import Data.Maybe (mapMaybe) @@ -83,20 +81,16 @@ import GHC , unLoc ) #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) --- import HsExtension (GhcRn) import GHC.Hs.Extension (GhcRn) #endif import HaskellCodeExplorer.GhcUtils (hsPatSynDetails, ieLocNames) import Prelude hiding (span) --- import TysWiredIn import GHC.Builtin.Types ( nilDataConName , tupleTyConName --- , typeNatKind , naturalTy , typeSymbolKind ) --- import SrcLoc import GHC.Types.SrcLoc ( mkRealSrcSpan , mkRealSrcLoc diff --git a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs index 0aa4191..d31634c 100644 --- a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs +++ b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -21,6 +22,9 @@ module HaskellCodeExplorer.AST.TypecheckedSource import GHC.Data.Bag (bagToList) import GHC.Types.Basic (Origin(..)) import GHC.Core.Class (Class, classTyVars) +import GHC.Core.ConLike (ConLike(..)) +import GHC.Core.DataCon (dataConRepType) +import GHC.Core.PatSyn (patSynBuilder) import Control.Monad (unless, void, when) import Control.Monad.State.Strict (State, get, modify') import Data.Either (isLeft, fromLeft) @@ -38,9 +42,17 @@ import GHC , getLocA , reLocA , reLocN + , SrcLoc(..) + , srcSpanStart + , srcSpanEnd + ) +import GHC.Data.FastString + ( mkFastString + , FastString + , unpackFS ) -import GHC.Data.FastString (mkFastString) import GHC.Unit.State (UnitState) +import GHC.Utils.Misc (thenCmp) import HaskellCodeExplorer.GhcUtils import qualified HaskellCodeExplorer.Types as HCE import GHC.Hs.Binds (RecordPatSynField(..) @@ -89,19 +101,14 @@ import GHC.Hs , PatSynBind(..) , StmtLR(..) , selectorAmbiguousFieldOcc -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) --- , RecordConTc (..) , RecordUpdTc (..) , ListPatTc (..) , OverLitTc (..) , MatchGroupTc (..) , NHsValBindsLR (..) -#endif ) import GHC.Types.TypeEnv (TypeEnv, lookupTypeEnv) -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) import GHC.Hs.Extension (GhcTc) -#endif import GHC.Types.Id (idType) import GHC.Types.Id.Info (IdDetails(..)) import GHC.Core.InstEnv @@ -120,20 +127,13 @@ import GHC.Types.SrcLoc , UnhelpfulSpanReason(..) , isOneLineSpan , unLoc --- #if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) --- , cL --- #endif ) import GHC.Tc.Types.Evidence (HsWrapper(..)) import GHC.Tc.Utils.Zonk (conLikeResTy, hsLitType) import GHC.Core.Predicate (getClassPredTys_maybe) import GHC.Core.Type ( Type -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) , nonDetCmpTypes -#else - , cmpTypes -#endif , eqTypes , eqType , mkVisFunTys @@ -210,11 +210,7 @@ exprSort HsIPVar {} = Simple exprSort HsOverLit {} = Simple exprSort HsLit {} = Simple -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) exprSort (ExplicitTuple _ args _) -#else -exprSort (ExplicitTuple args _) -#endif | null args = Simple | otherwise = Composite exprSort (ExplicitList _ args) @@ -227,18 +223,10 @@ patSort :: Pat a -> ExprSort patSort WildPat {} = Simple patSort LitPat {} = Simple patSort NPat {} = Simple -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) patSort (ListPat _ pats) -#else -patSort (ListPat pats _ _) -#endif | null pats = Simple | otherwise = Composite -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) patSort (TuplePat _ pats _) -#else -patSort (TuplePat pats _ _) -#endif | null pats = Simple | otherwise = Composite patSort _ = Composite @@ -291,6 +279,16 @@ funResultTy2Safe srcSpan astNode typ = do Just resTy1 -> funResultTySafe srcSpan astNode resTy1 Nothing -> return Nothing +instance Ord FastString where + a `compare` b = unpackFS a `compare` unpackFS b + +deriving instance () => Ord SrcLoc + +instance Ord SrcSpan where + a `compare` b = + (srcSpanStart a `compare` srcSpanStart b) `thenCmp` + (srcSpanEnd a `compare` srcSpanEnd b) + addIdentifierToIdSrcSpanMap :: SrcSpan -> Id -> Maybe (Type, [Type]) -> State ASTState () addIdentifierToIdSrcSpanMap span identifier mbTypes @@ -557,14 +555,6 @@ restoreTidyEnv action = do modify' $ \s -> s {astStateTidyEnv = tidyEnv} return res --- not used any more --- restoreHsWrapper :: (State ASTState) a -> (State ASTState) a --- restoreHsWrapper action = do --- wrapper <- astStateHsWrapper <$> get --- res <- action --- modify' $ \s -> s {astStateHsWrapper = wrapper} --- return res - tidyIdentifier :: Id -> State ASTState (Id, Maybe (Type, [Type])) tidyIdentifier identifier = do tidyEnv <- astStateTidyEnv <$> get @@ -613,12 +603,14 @@ foldLHsExpr lhe@(L _ (HsVar _ (L _ identifier))) = addIdentifierToIdSrcSpanMap (getLocA lhe) identifier' mbTypes return . Just . varType $ identifier' foldLHsExpr (L _ HsUnboundVar {}) = return Nothing -foldLHsExpr (L _ (HsConLikeOut _ _)) = - -- restoreTidyEnv $ do - -- let mbType = varType <$> conLikeWrapId_maybe conLike - -- mbType' <- maybe (return Nothing) (fmap Just . tidyType) mbType - -- return mbType' - restoreTidyEnv $ return Nothing +-- The logic does not match exactly with the old logic, i.e. (varType . dataConWrapId) and dataConRepType have seemingly different definitions. +foldLHsExpr (L _ (HsConLikeOut _ conLike)) = + restoreTidyEnv $ do + let mbType = case conLike of + RealDataCon dataCon -> Just $ dataConRepType dataCon + PatSynCon patSyn -> (\(_, typ, _) -> typ) <$> patSynBuilder patSyn + mbType' <- maybe (return Nothing) (fmap Just . tidyType) mbType + return mbType' foldLHsExpr (L _ HsRecFld {}) = return Nothing foldLHsExpr (L _ HsOverLabel {}) = return Nothing foldLHsExpr lhe@(L _ expr@HsIPVar {}) = do @@ -806,14 +798,6 @@ foldLHsExpr lhe@(L _ e@(HsPragE _ (HsPragSCC {}) expr)) = do typ <- foldLHsExpr expr addExprInfo (getLocA lhe) typ "HsSCC" (exprSort e) return typ --- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) --- foldLHsExpr lhe@(L _ e@(HsCoreAnn _ _sourceText _fastString expr)) = do --- #else --- foldLHsExpr lhe@(L _ e@(HsCoreAnn _sourceText _fastString expr)) = do --- #endif --- typ <- foldLHsExpr expr --- addExprInfo (getLocA lhe) typ "HsCoreAnn" (exprSort e) --- return typ foldLHsExpr (L _span HsBracket {}) = return Nothing foldLHsExpr (L _span HsRnBracketOut {}) = return Nothing foldLHsExpr (L _span HsTcBracketOut {}) = return Nothing @@ -827,8 +811,6 @@ foldLHsExpr lhe@(L _ e@(HsStatic _ expr)) = do typ <- foldLHsExpr expr addExprInfo (getLocA lhe) typ "HsStatic" (exprSort e) return typ --- foldLHsExpr (L _ HsArrForm {}) = return Nothing --- foldLHsExpr (L _ HsArrApp {}) = return Nothing foldLHsExpr lhe@(L _ e@(HsTick _ _ expr)) = do typ <- foldLHsExpr expr addExprInfo (getLocA lhe) typ "HsTick" (exprSort e) @@ -837,33 +819,6 @@ foldLHsExpr lhe@(L _ e@(HsBinTick _ _ _ expr)) = do typ <- foldLHsExpr expr addExprInfo (getLocA lhe) typ "HsBinTick" (exprSort e) return typ --- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) --- foldLHsExpr (L span e@(HsTickPragma _ _ _ _ expr)) = do --- #else --- foldLHsExpr (L span e@(HsTickPragma _ _ _ expr)) = do --- #endif --- typ <- foldLHsExpr expr --- addExprInfo span typ "HsTickPragma" (exprSort e) --- return typ - --- A few similarly named symbols are in GHC.Hs.Pat --- foldLHsExpr (L _span EWildPat {}) = return Nothing --- foldLHsExpr (L _span EAsPat {}) = return Nothing --- foldLHsExpr (L _span EViewPat {}) = return Nothing --- foldLHsExpr (L _span ELazyPat {}) = return Nothing - --- there's an hswrap but it is not in hsexpr --- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) --- foldLHsExpr (L span (HsWrap _ wrapper expr)) = --- #else --- foldLHsExpr (L span (HsWrap wrapper expr)) = --- #endif --- restoreHsWrapper $ do --- case exprSort expr of --- Simple -> modify' (\s -> s {astStateHsWrapper = Just wrapper}) --- Composite -> return () -- Not sure if it is possible --- typ <- foldLHsExpr (L span expr) --- return $ applyWrapper wrapper <$> typ foldHsRecFields :: HsRecFields GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) foldHsRecFields HsRecFields {..} = do @@ -874,11 +829,7 @@ foldHsRecFields HsRecFields {..} = do mapM_ foldLHsRecField $ userWritten rec_flds return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLHsRecField :: LHsRecField GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) -#else -foldLHsRecField :: LHsRecField Id (LHsExpr Id) -> State ASTState (Maybe Type) -#endif foldLHsRecField lhr@(L _ (HsRecField _ (L idSpan (FieldOcc identifier _)) arg pun)) = restoreTidyEnv $ do (identifier', mbTypes) <- tidyIdentifier identifier @@ -1241,7 +1192,7 @@ foldLPat lp@(L _ pat@(PArrPat pats typ)) = do mapM_ foldLPat pats return $ Just typ' #endif --- no more conpatin / conpatout, just conpat +-- no more conpatin / conpatout, just conpat (in the wildcard pattern _) -- foldLPat (ghcDL -> L _span (ConPatIn _ _)) = return Nothing -- TODO: FIXME -- foldLPat (ghcDL -> cp@lp@(L _ pat@ConPat {..})) = do @@ -1317,48 +1268,8 @@ foldLPat (L _span (SigPatOut pat typ)) = do _ <- foldLPat pat return $ Just typ' #endif --- no copat in lpat in 9.2.2 --- foldLPat lp@(L span p@(CoPat _ pat typ)) = do --- typ' <- tidyType typ --- addExprInfo (getLocA lp) (Just typ') "CoPat" (patSort p) --- -- cL is similar to dL and not used any more --- -- _ <- foldLPat (cL (getLocA lp) pat) --- _ <- foldLPat (L span pat) --- return Nothing foldLPat _ = return Nothing --- no longer used --- foldHsConPatDetails --- :: HsConPatDetails GhcTc --- -> State ASTState (Maybe Type) --- foldHsConPatDetails (PrefixCon _ args) = do --- mapM_ foldLPat args --- return Nothing --- foldHsConPatDetails (RecCon rec) = do --- _ <- foldHsRecFieldsPat rec --- return Nothing --- foldHsConPatDetails (InfixCon arg1 arg2) = do --- _ <- foldLPat arg1 --- _ <- foldLPat arg2 --- return Nothing - --- no longer used --- foldHsRecFieldsPat :: HsRecFields GhcTc (LPat GhcTc) -> State ASTState (Maybe Type) --- foldHsRecFieldsPat HsRecFields {..} = do --- let onlyUserWritten = --- case rec_dotdot of --- Just i -> take $ unLoc i --- Nothing -> id --- mapM_ foldLHsRecFieldPat $ onlyUserWritten rec_flds --- return Nothing --- foldLHsRecFieldPat :: LHsRecField GhcTc (LPat GhcTc) -> State ASTState (Maybe Type) --- foldLHsRecFieldPat (L _ (HsRecField _ (L idSpan (FieldOcc identifier _)) arg pun)) = do --- (identifier', mbTypes) <- tidyIdentifier identifier --- addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes --- unless pun $ void $ foldLPat arg --- return . Just . varType $ identifier' --- foldLHsRecFieldPat (L _ (HsRecField _ (L _idSpan (XFieldOcc _)) _arg _pun)) = return Nothing - foldLHsCmdTop :: LHsCmdTop GhcTc -> State ASTState (Maybe Type) foldLHsCmdTop (L span (HsCmdTop _ cmd)) = do mbTyp <- foldLHsCmd cmd @@ -1406,11 +1317,3 @@ foldLHsCmd (L _ (HsCmdLet _ binds cmd)) = do foldLHsCmd (L _ (HsCmdDo _ stmts)) = do mapM_ foldLStmtLRCmd $ unLoc stmts return Nothing --- no more hscmdwrap --- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) --- foldLHsCmd (L span (HsCmdWrap _ _ cmd)) = do --- #else --- foldLHsCmd (L span (HsCmdWrap _ cmd)) = do --- #endif --- _ <- foldLHsCmd (L span cmd) --- return Nothing diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs index 0a106ad..f8a2b06 100644 --- a/src/HaskellCodeExplorer/GhcUtils.hs +++ b/src/HaskellCodeExplorer/GhcUtils.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} @@ -61,9 +60,7 @@ module HaskellCodeExplorer.GhcUtils , hsDocsToDocH , subordinateNamesWithDocs ) where --- import Bag (bagToList) import GHC.Data.Bag (bagToList) --- import ConLike (ConLike(..)) import GHC.Core.ConLike (ConLike(..)) import GHC.HsToCore.Docs ( collectDocs @@ -81,7 +78,6 @@ 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 DataCon (dataConWorkId, flSelector) import GHC.Core.DataCon (dataConWorkId) import Documentation.Haddock.Parser (overIdentifier, parseParas) import Documentation.Haddock.Types @@ -90,19 +86,15 @@ import Documentation.Haddock.Types , _doc , Namespace ) --- import DynFlags () --- import FastString (mkFastString, unpackFS) import GHC.Data.FastString ( mkFastString , unpackFS - , FastString ) import GHC ( DynFlags - , XRec + , sortLocatedA , getRecConArgs_maybe , ConDeclField(..) - , LConDeclField , CollectFlag(..) , LHsBindLR , reLocN @@ -110,19 +102,11 @@ import GHC , UnXRec , GhcPass , recordPatSynField -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) , HsDocString -#else - , HsDocString (..) -#endif , InstDecl(..) , Name , SrcSpan(..) - , srcSpanStart - , srcSpanEnd - , SrcLoc(..) , RealSrcSpan(..) - , SrcSpanAnnA , ClsInstDecl(..) , TyClDecl(..) , HsDataDefn(..) @@ -131,11 +115,7 @@ import GHC , rdrNameFieldOcc , HsGroup(..) , HsValBindsLR(..) -#if MIN_VERSION_GLASGOW_HASKELL(8,4,1,0) , HsPatSynDetails -#else - , HsPatSynDetails(..) -#endif , Located , IE(..) , TyThing(..) @@ -150,28 +130,14 @@ import GHC , tcdName , collectHsBindBinders , getLocA --- , hsSigType , getConNames -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) , NHsValBindsLR(..) --- , getConArgs , unpackHDS , NoExtField(..) --- , NoExt(..) , extFieldOcc -#else - , getConDetails - , selectorFieldOcc -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) , LIEWrappedName , ieLWrappedName -#else - , tyClGroupConcat -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) , FamEqn(..) -#endif , tyConKind , nameSrcSpan , srcSpanFile @@ -180,46 +146,26 @@ import GHC , srcSpanStartCol , srcSpanEndCol , isExternalName --- , recordPatSynSelectorId , recordPatSynPatVar , isGoodSrcSpan , isLocalId , isDataFamilyDecl , tyFamInstDeclName , idType --- , hsib_body -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -#else - , tfe_pats -#endif , tfid_eqn -#if MIN_VERSION_ghc(8,8,0) --- , dL --- , HasSrcSpan --- , SrcSpanLess -#endif ) import qualified HaskellCodeExplorer.Types as HCE --- import HscTypes (TypeEnv, lookupTypeEnv) import GHC.Types.TypeEnv (TypeEnv, lookupTypeEnv) -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) --- import HsExtension (GhcRn,IdP) import GHC.Hs.Extension (GhcRn) import Language.Haskell.Syntax.Extension (IdP) -#endif --- import IdInfo (IdDetails(..)) import GHC.Types.Id.Info (IdDetails(..)) --- import InstEnv (ClsInst(..)) import GHC.Core.InstEnv (ClsInst(..)) --- import GHC.Parser.Lexer (ParseResult(POk), mkPState, unP) import GHC.Parser.Lexer ( ParseResult(POk) , initParserState , unP ) --- import Module (Module(..)) --- import Name import GHC.Types.Name ( isDataConNameSpace , isDerivedOccName @@ -239,49 +185,33 @@ import GHC.Types.Name , occNameString , wiredInNameTyThing_maybe ) --- import OccName (OccName) import GHC.Types.Name.Occurrence (OccName) --- import Outputable (Outputable, ppr, showPpr, showSDoc) import GHC.Utils.Outputable (Outputable, ppr) -import GHC.Utils.Misc (thenCmp) import GHC.Driver.Config (initParserOpts) import GHC.Driver.Ppr (showPpr, showSDoc) --- import PackageConfig (packageVersion) --- import Packages import GHC.Unit.State ( LookupResult(..) , lookupModuleWithSuggestions , lookupUnit --- , lookupPackage --- , packageNameString ) --- import Pair (pSnd) import GHC.Data.Pair (pSnd) --- import Parser (parseIdentifier) import GHC.Parser (parseIdentifier) --- import PatSyn (PatSyn, patSynMatcher, patSynSig) import GHC.Core.PatSyn (PatSyn, patSynMatcher, patSynSig) import Prelude hiding (id, span) --- import RdrName (GlobalRdrEnv, RdrName(..), gre_name, lookupGRE_RdrName) import GHC.Types.Name.Reader ( GlobalRdrEnv , RdrName(..) , grePrintableName , lookupGRE_RdrName) --- import RnEnv (dataTcOccs) import GHC.Rename.Env (dataTcOccs) --- import SrcLoc (GenLocated(..), mkRealSrcLoc, unLoc) import GHC.Types.SrcLoc ( GenLocated(..) , mkRealSrcLoc , unLoc ) --- import StringBuffer (StringBuffer(..), stringToStringBuffer) import GHC.Data.StringBuffer (StringBuffer(..), stringToStringBuffer) import System.FilePath (normalise) --- import TcEvidence (HsWrapper(..), tcCoercionKind) import GHC.Tc.Types.Evidence (HsWrapper(..), tcCoercionKind) --- import TcType (evVarPred) import GHC.Tc.Utils.TcType (evVarPred) import GHC.Core.TyCo.Rep ( Type(..) @@ -290,39 +220,24 @@ import GHC.Core.TyCo.Rep , mkVisFunTysMany , scaledThing ) --- import TyCon (tyConName) import GHC.Core.TyCon (tyConName) --- import Type import GHC.Core.Type ( coreView , expandTypeSynonyms , mkForAllTy , mkTyCoInvForAllTys --- , mkFunTys --- , mkInvForAllTys , piResultTy , splitFunTy_maybe , tidyOpenType ) import GHC.Core.TyCo.Ppr (pprSigmaType) -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) import GHC.CoreToIface --- import IfaceType import GHC.Iface.Type -#endif --- import TysWiredIn (unitTy) import GHC.Builtin.Types (unitTy) --- import UniqSet (emptyUniqSet, unionUniqSets, import GHC.Types.Unique.Set (emptyUniqSet, unionUniqSets, -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) nonDetEltsUniqSet -#else - uniqSetToList -#endif ) --- import Unique (getKey) import GHC.Types.Unique (getKey) --- import Var import GHC.Types.Var ( idDetails , isId @@ -333,14 +248,8 @@ import GHC.Types.Var , varType , varUnique ) --- import VarEnv (TidyEnv) import GHC.Types.Var.Env (TidyEnv) --- import VarSet (VarSet, emptyVarSet, unionVarSet, unitVarSet import GHC.Types.Var.Set (VarSet, emptyVarSet, unionVarSet, unitVarSet -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) -#else - ,varSetElems -#endif ) import GHC.Unit @@ -1036,61 +945,23 @@ tyVarsOfType = varSetElems . everything unionVarSet (emptyVarSet `mkQ` tyVar) -- Some functions are copied from haddock-api package -------------------------------------------------------------------------------- --- collectDocs is available in GHC.HsToCore.Docs --- collectDocs :: [LHsDecl p] -> [(LHsDecl p, [HsDocString])] - -- available in GHC.HsToCore.Docs --- #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +-- collectDocs :: [LHsDecl p] -> [(LHsDecl p, [HsDocString])] -- ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] --- #else --- ungroup :: HsGroup Name -> [LHsDecl Name] --- #endif - --- also available in GHC.HsToCore.Docs -- Take a field of declarations from a data structure and create HsDecls using the given constructor -- mkDecls :: (struct -> [GenLocated l decl]) -> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl] --- mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c] --- mkDecls field con struct = [L loc (con decl) | L loc decl <- field struct] - -instance Ord FastString where - a `compare` b = unpackFS a `compare` unpackFS b - -deriving instance () => Ord SrcLoc - -instance Ord SrcSpan where - a `compare` b = - (srcSpanStart a `compare` srcSpanStart b) `thenCmp` - (srcSpanEnd a `compare` srcSpanEnd b) -sortByLoc :: [GenLocated SrcSpanAnnA a] -> [GenLocated SrcSpanAnnA a] -sortByLoc = L.sortOn getLocA - -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) classDeclDocs :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] -#else -classDeclDocs :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])] -#endif -classDeclDocs class_ = collectDocs . sortByLoc $ decls +classDeclDocs class_ = collectDocs . sortLocatedA $ decls where decls = docs ++ defs ++ sigs ++ ats -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) 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_ -#else - docs = mkDecls tcdDocs DocD class_ - defs = mkDecls (bagToList . tcdMeths) ValD class_ - sigs = mkDecls tcdSigs SigD class_ - ats = mkDecls tcdATs (TyClD . FamDecl) class_ -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) conDeclDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)] -#else -conDeclDocs :: ConDecl Name -> [(Name, [HsDocString], SrcSpan)] -#endif conDeclDocs conDecl = map (\con -> (unLoc con, maybe [] ((: []) . unLoc) $ con_doc conDecl, getLocA con)) . getConNames $ @@ -1126,13 +997,6 @@ subordinateNamesWithDocs = _ -> []) --- no longer needed by ungroup --- isUserLSig :: forall p. UnXRec p => LSig p -> Bool --- isUserLSig sig = case unXRec @p sig of --- TypeSig {} -> True --- ClassOpSig {} -> True --- _ -> False - #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) getMainDeclBinder :: HsDecl GhcRn -> [IdP GhcRn] #else @@ -1180,10 +1044,6 @@ sigNameNoLoc _ = [] clsInstDeclSrcSpan :: ClsInstDecl (GhcPass p) -> SrcSpan clsInstDeclSrcSpan ClsInstDecl {cid_poly_ty = ty} = getLocA ty --- Pattern match is redundant --- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) --- clsInstDeclSrcSpan (XClsInstDecl _) = UnhelpfulSpan (UnhelpfulOther "XClsinstdecl") --- #endif hsDocsToDocH :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Doc Name hsDocsToDocH flags rdrEnv = @@ -1305,11 +1165,5 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r isLegal '.' = True isLegal c = isAscii c && isAlphaNum c --- no more HasSrcSpan or SrcSpanLess --- #if MIN_VERSION_ghc(8,8,0) --- ghcDL :: GHC.HasSrcSpan a => a -> GHC.Located (GHC.SrcSpanLess a) --- ghcDL = GHC.dL --- #else ghcDL :: GHC.Located a -> GHC.Located a ghcDL x = x --- #endif |