From 166265e93de140c4a33f7a61bc004fb64be18275 Mon Sep 17 00:00:00 2001 From: alexwl Date: Tue, 9 Oct 2018 23:13:07 +0300 Subject: WIP. It compiles with ghc-8.4.3, but not all features of the indexer are supported yet. --- src/HaskellCodeExplorer/AST/RenamedSource.hs | 105 ++++++++++++++----- src/HaskellCodeExplorer/AST/TypecheckedSource.hs | 128 +++++++++++++++++------ src/HaskellCodeExplorer/GhcUtils.hs | 56 +++++++--- src/HaskellCodeExplorer/ModuleInfo.hs | 39 +++++-- 4 files changed, 246 insertions(+), 82 deletions(-) (limited to 'src/HaskellCodeExplorer') diff --git a/src/HaskellCodeExplorer/AST/RenamedSource.hs b/src/HaskellCodeExplorer/AST/RenamedSource.hs index c1bf463..ea5a87a 100644 --- a/src/HaskellCodeExplorer/AST/RenamedSource.hs +++ b/src/HaskellCodeExplorer/AST/RenamedSource.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} @@ -54,10 +55,16 @@ import GHC , PatSynBind(..) , Sig(..) , TyClDecl(..) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +#else , TyFamEqn(..) +#endif , Type , unLoc ) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +import HsExtension (GhcRn) +#endif import HaskellCodeExplorer.GhcUtils (hsPatSynDetails, ieLocNames) import Prelude hiding (span) import TysWiredIn @@ -86,9 +93,12 @@ namesFromRenamedSource = hsTypeNames `extQ` tyClDeclNames `extQ` familyDeclNames `extQ` +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +#else tyFamilyEqNames `extQ` tyFamilyDefEqNames `extQ` dataFamInstDeclNames `extQ` +#endif conDeclNames `extQ` importNames `extQ` hsTyVarBndrNames `extQ` @@ -99,7 +109,9 @@ namesFromRenamedSource = hsRecFieldPatNames `extQ` foreignDeclNames) -fieldOccName :: Bool -> FieldOcc Name -> NameOccurrence +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +fieldOccName :: Bool -> FieldOcc GhcRn -> NameOccurrence +#endif fieldOccName isBinder (FieldOcc (L span _) name) = NameOccurrence { locatedName = L span (Just name) @@ -107,16 +119,20 @@ fieldOccName isBinder (FieldOcc (L span _) name) = , isBinder = isBinder } -conDeclFieldNames :: ConDeclField Name -> [NameOccurrence] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +conDeclFieldNames :: ConDeclField GhcRn -> [NameOccurrence] +#endif conDeclFieldNames ConDeclField {..} = map (fieldOccName True . unLoc) cd_fld_names -hsRecFieldExprNames :: - HsRecField' (FieldOcc Name) (LHsExpr Name) -> [NameOccurrence] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +hsRecFieldExprNames :: HsRecField' (FieldOcc GhcRn) (LHsExpr GhcRn) -> [NameOccurrence] +#endif hsRecFieldExprNames HsRecField {..} = [fieldOccName False $ unLoc hsRecFieldLbl] -hsRecAmbFieldExprNames :: - HsRecField' (AmbiguousFieldOcc Name) (LHsExpr Name) -> [NameOccurrence] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +hsRecAmbFieldExprNames :: HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn) -> [NameOccurrence] +#endif hsRecAmbFieldExprNames HsRecField {..} = let (L span recField) = hsRecFieldLbl mbName = @@ -130,11 +146,14 @@ hsRecAmbFieldExprNames HsRecField {..} = } ] -hsRecFieldPatNames :: - HsRecField' (FieldOcc Name) (LPat Name) -> [NameOccurrence] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +hsRecFieldPatNames :: HsRecField' (FieldOcc GhcRn) (LPat GhcRn) -> [NameOccurrence] +#endif hsRecFieldPatNames HsRecField {..} = [fieldOccName False $ unLoc hsRecFieldLbl] -hsExprNames :: LHsExpr Name -> [NameOccurrence] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +hsExprNames :: LHsExpr GhcRn -> [NameOccurrence] +#endif hsExprNames (L _span (HsVar name)) = [ NameOccurrence { locatedName = Just <$> name @@ -174,7 +193,9 @@ hsExprNames (L _span (HsRecFld (Ambiguous (L span _) _name))) = ] hsExprNames _ = [] -matchGroupNames :: MatchGroup Name (LHsExpr Name) -> [NameOccurrence] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +matchGroupNames :: MatchGroup GhcRn (LHsExpr GhcRn) -> [NameOccurrence] +#endif matchGroupNames = #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) mapMaybe (fmap toNameOcc . matchContextName . m_ctxt . unLoc) . @@ -184,20 +205,22 @@ matchGroupNames = unLoc . mg_alts where #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) - matchContextName :: HsMatchContext Name -> Maybe (Located Name) + --matchContextName :: HsMatchContext Name -> Maybe (Located Name) matchContextName (FunRhs name _ _bool) = Just name matchContextName _ = Nothing #else - matchFixityName :: MatchFixity Name -> Maybe (Located Name) + --matchFixityName :: MatchFixity Name -> Maybe (Located Name) matchFixityName NonFunBindMatch = Nothing matchFixityName (FunBindMatch name _bool) = Just name #endif - toNameOcc :: Located Name -> NameOccurrence + --toNameOcc :: Located Name -> NameOccurrence toNameOcc n = NameOccurrence {locatedName = Just <$> n, description = "Match", isBinder = True} -bindNames :: LHsBindLR Name Name -> [NameOccurrence] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +bindNames :: LHsBindLR GhcRn GhcRn -> [NameOccurrence] +#endif bindNames (L _span (PatSynBind PSB {..})) = [ NameOccurrence { locatedName = Just <$> psb_id @@ -207,7 +230,6 @@ bindNames (L _span (PatSynBind PSB {..})) = ] bindNames _ = [] -hsPatSynDetailsNames :: HsPatSynDetails (Located Name) -> [NameOccurrence] hsPatSynDetailsNames = map (\name -> @@ -218,7 +240,10 @@ hsPatSynDetailsNames = }) . hsPatSynDetails -importNames :: IE Name -> [NameOccurrence] + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +importNames :: IE GhcRn -> [NameOccurrence] +#endif importNames = map (\name -> @@ -229,7 +254,10 @@ importNames = }) . ieLocNames -patNames :: LPat Name -> [NameOccurrence] + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +patNames :: LPat GhcRn -> [NameOccurrence] +#endif patNames (L _span (VarPat name)) = [ NameOccurrence { locatedName = Just <$> name @@ -260,7 +288,10 @@ patNames (L _span (NPlusKPat name _ _ _ _ _)) = ] patNames _ = [] -sigNames :: LSig Name -> [NameOccurrence] + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +sigNames :: LSig GhcRn -> [NameOccurrence] +#endif sigNames (L _span (TypeSig names _)) = map (\n -> @@ -332,7 +363,10 @@ sigNames (L _span (MinimalSig _ (L _ boolFormula))) = boolFormulaNames (Parens (L _ f)) = boolFormulaNames f sigNames (L _ _) = [] -hsTypeNames :: LHsType Name -> [NameOccurrence] + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +hsTypeNames :: LHsType GhcRn -> [NameOccurrence] +#endif #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) hsTypeNames (L _span (HsTyVar _promoted name)) = #else @@ -382,7 +416,10 @@ hsTypeNames (L span (HsTupleTy tupleSort types)) --hsTypeNames (L span (HsExplicitTupleTy _kind types)) = ... hsTypeNames _ = [] -hsTyVarBndrNames :: HsTyVarBndr Name -> [NameOccurrence] + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +hsTyVarBndrNames :: HsTyVarBndr GhcRn -> [NameOccurrence] +#endif hsTyVarBndrNames (UserTyVar n) = [ NameOccurrence { locatedName = Just <$> n @@ -398,7 +435,9 @@ hsTyVarBndrNames (KindedTyVar n _) = } ] -tyClDeclNames :: LTyClDecl Name -> [NameOccurrence] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +tyClDeclNames :: LTyClDecl GhcRn -> [NameOccurrence] +#endif tyClDeclNames (L _span DataDecl {..}) = [ NameOccurrence { locatedName = Just <$> tcdLName @@ -432,7 +471,9 @@ tyClDeclNames (L _span ClassDecl {..}) = } tyClDeclNames _ = [] -familyDeclNames :: FamilyDecl Name -> [NameOccurrence] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +familyDeclNames :: FamilyDecl GhcRn -> [NameOccurrence] +#endif familyDeclNames FamilyDecl {..} = [ NameOccurrence { locatedName = Just <$> fdLName @@ -441,7 +482,11 @@ familyDeclNames FamilyDecl {..} = } ] -tyFamilyEqNames :: TyFamEqn Name (HsTyPats Name) -> [NameOccurrence] + +--TODO +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +#else +--tyFamilyEqNames :: TyFamEqn Name (HsTyPats Name) -> [NameOccurrence] tyFamilyEqNames TyFamEqn {tfe_tycon = tyCon} = [ NameOccurrence { locatedName = Just <$> tyCon @@ -450,7 +495,7 @@ tyFamilyEqNames TyFamEqn {tfe_tycon = tyCon} = } ] -tyFamilyDefEqNames :: TyFamEqn Name (LHsQTyVars Name) -> [NameOccurrence] +--tyFamilyDefEqNames :: TyFamEqn Name (LHsQTyVars Name) -> [NameOccurrence] tyFamilyDefEqNames TyFamEqn {tfe_tycon = tyCon} = [ NameOccurrence { locatedName = Just <$> tyCon @@ -459,7 +504,8 @@ tyFamilyDefEqNames TyFamEqn {tfe_tycon = tyCon} = } ] -dataFamInstDeclNames :: DataFamInstDecl Name -> [NameOccurrence] + +--dataFamInstDeclNames :: DataFamInstDecl Name -> [NameOccurrence] dataFamInstDeclNames DataFamInstDecl {dfid_tycon = tyCon} = [ NameOccurrence { locatedName = Just <$> tyCon @@ -467,8 +513,11 @@ dataFamInstDeclNames DataFamInstDecl {dfid_tycon = tyCon} = , isBinder = False } ] +#endif -conDeclNames :: ConDecl Name -> [NameOccurrence] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +conDeclNames :: ConDecl GhcRn -> [NameOccurrence] +#endif conDeclNames con = case con of ConDeclGADT {con_names = names} -> @@ -488,7 +537,9 @@ conDeclNames con = } ] -foreignDeclNames :: ForeignDecl Name -> [NameOccurrence] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foreignDeclNames :: ForeignDecl GhcRn -> [NameOccurrence] +#endif foreignDeclNames decl = [ NameOccurrence { locatedName = Just <$> fd_name decl diff --git a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs index f97c33b..4dfbd8b 100644 --- a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs +++ b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs @@ -80,6 +80,7 @@ import HsSyn , selectorAmbiguousFieldOcc ) import HscTypes (TypeEnv, lookupTypeEnv) +import HsExtension (GhcTc) import Id (idType) import IdInfo (IdDetails(..)) import InstEnv @@ -541,11 +542,15 @@ tidyType typ = do let (tidyEnv', typ') = tidyOpenType tidyEnv typ modify' (\s -> s {astStateTidyEnv = tidyEnv'}) return typ' - -foldTypecheckedSource :: LHsBinds Id -> State ASTState () + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldTypecheckedSource :: LHsBinds GhcTc -> State ASTState () +#endif foldTypecheckedSource = foldLHsBindsLR -foldLHsExpr :: LHsExpr Var -> State ASTState (Maybe Type) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldLHsExpr :: LHsExpr GhcTc -> State ASTState (Maybe Type) +#endif foldLHsExpr (L span (HsVar (L _ identifier))) = restoreTidyEnv $ do (identifier', mbTypes) <- tidyIdentifier identifier @@ -801,8 +806,10 @@ foldLHsExpr (L span (HsWrap wrapper expr)) = Composite -> return () -- Not sure if it is possible typ <- foldLHsExpr (L span expr) return $ applyWrapper wrapper <$> typ - -foldHsRecFields :: HsRecFields Id (LHsExpr Id) -> State ASTState (Maybe Type) + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldHsRecFields :: HsRecFields GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +#endif foldHsRecFields HsRecFields {..} = do let userWritten = case rec_dotdot of @@ -810,8 +817,10 @@ foldHsRecFields HsRecFields {..} = do Nothing -> id mapM_ foldLHsRecField $ userWritten rec_flds return Nothing - -foldLHsRecField :: LHsRecField Id (LHsExpr Id) -> State ASTState (Maybe Type) + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldLHsRecField :: LHsRecField GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +#endif foldLHsRecField (L span (HsRecField (L idSpan (FieldOcc _ identifier)) arg pun)) = restoreTidyEnv $ do (identifier', mbTypes) <- tidyIdentifier identifier @@ -820,7 +829,9 @@ foldLHsRecField (L span (HsRecField (L idSpan (FieldOcc _ identifier)) arg pun)) unless pun $ void (foldLHsExpr arg) return . Just . varType $ identifier' -foldLHsRecUpdField :: LHsRecUpdField Id -> State ASTState (Maybe Type) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldLHsRecUpdField :: LHsRecUpdField GhcTc -> State ASTState (Maybe Type) +#endif foldLHsRecUpdField (L span (HsRecField (L idSpan recField) arg pun)) = restoreTidyEnv $ do let selectorId = selectorAmbiguousFieldOcc recField @@ -844,7 +855,9 @@ data TupArg | TupArgMissing deriving (Show, Eq) -foldLHsTupArg :: LHsTupArg Id -> State ASTState (Maybe Type, TupArg) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldLHsTupArg :: LHsTupArg GhcTc -> State ASTState (Maybe Type, TupArg) +#endif foldLHsTupArg (L _span (Present expr)) = restoreTidyEnv $ do typ <- foldLHsExpr expr @@ -858,31 +871,41 @@ foldLHsTupArg (L _ (Missing typ)) = typ' <- tidyType typ return (Just typ', TupArgMissing) -foldLMatch :: LMatch Id (LHsExpr Var) -> State ASTState (Maybe Type) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldLMatch :: LMatch GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +#endif foldLMatch (L _span Match {..}) = do mapM_ foldLPat m_pats _ <- foldGRHSs m_grhss return Nothing - -foldLMatchCmd :: LMatch Id (LHsCmd Var) -> State ASTState (Maybe Type) + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldLMatchCmd :: LMatch GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type) +#endif foldLMatchCmd (L _span Match {..}) = do mapM_ foldLPat m_pats _ <- foldGRHSsCmd m_grhss return Nothing -foldGRHSsCmd :: GRHSs Id (LHsCmd Id) -> State ASTState (Maybe Type) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldGRHSsCmd :: GRHSs GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type) +#endif foldGRHSsCmd GRHSs {..} = do mapM_ foldLGRHSCmd grhssGRHSs _ <- foldHsLocalBindsLR (unLoc grhssLocalBinds) return Nothing -foldGRHSs :: GRHSs Id (LHsExpr Var) -> State ASTState (Maybe Type) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldGRHSs :: GRHSs GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +#endif foldGRHSs GRHSs {..} = do mapM_ foldLGRHS grhssGRHSs _ <- foldHsLocalBindsLR (unLoc grhssLocalBinds) return Nothing -foldLStmtLR :: LStmtLR Id Id (LHsExpr Var) -> State ASTState (Maybe Type) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldLStmtLR :: LStmtLR GhcTc GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +#endif foldLStmtLR (L span (LastStmt body _ _)) = do typ <- foldLHsExpr body addExprInfo span typ "LastStmt" Composite @@ -916,10 +939,16 @@ foldLStmtLR (L span (ApplicativeStmt args _ typ)) = addExprInfo span (Just typ') "ApplicativeStmt" Composite return Nothing -foldApplicativeArg :: ApplicativeArg Id Id -> State ASTState (Maybe Type) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldApplicativeArg :: ApplicativeArg GhcTc GhcTc -> State ASTState (Maybe Type) +#endif foldApplicativeArg appArg = case appArg of +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + ApplicativeArgOne pat expr _bool -> do +#else ApplicativeArgOne pat expr -> do +#endif _ <- foldLPat pat _ <- foldLHsExpr expr return Nothing @@ -927,9 +956,10 @@ foldApplicativeArg appArg = _ <- mapM_ foldLStmtLR exprStmts _ <- foldLPat pat return Nothing - -foldLStmtLRCmd :: LStmtLR Id Id (LHsCmd Var) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldLStmtLRCmd :: LStmtLR GhcTc GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type) +#endif foldLStmtLRCmd (L span (LastStmt body _syntaxExpr _)) = do typ <- foldLHsCmd body addExprInfo span typ "LastStmt Cmd" Composite @@ -962,43 +992,57 @@ foldLStmtLRCmd (L span (ApplicativeStmt args _ typ)) = mapM_ (foldApplicativeArg . snd) args addExprInfo span (Just typ') "ApplicativeStmt Cmd" Composite return Nothing - -foldLGRHS :: LGRHS Id (LHsExpr Id) -> State ASTState (Maybe Type) + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldLGRHS :: LGRHS GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +#endif foldLGRHS (L _span (GRHS guards body)) = do typ <- foldLHsExpr body mapM_ foldLStmtLR guards return typ - -foldLGRHSCmd :: LGRHS Id (LHsCmd Var) -> State ASTState (Maybe Type) + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldLGRHSCmd :: LGRHS GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type) +#endif foldLGRHSCmd (L _span (GRHS guards body)) = do typ <- foldLHsCmd body mapM_ foldLStmtLR guards return typ -foldParStmtBlock :: ParStmtBlock Id Id -> State ASTState (Maybe Type) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldParStmtBlock :: ParStmtBlock GhcTc GhcTc -> State ASTState (Maybe Type) +#endif foldParStmtBlock (ParStmtBlock exprStmts _ids _syntaxExpr) = do mapM_ foldLStmtLR exprStmts return Nothing -foldHsLocalBindsLR :: HsLocalBindsLR Id Id -> State ASTState (Maybe Type) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldHsLocalBindsLR :: HsLocalBindsLR GhcTc GhcTc -> State ASTState (Maybe Type) +#endif foldHsLocalBindsLR (HsValBinds binds) = do _ <- foldHsValBindsLR binds return Nothing foldHsLocalBindsLR (HsIPBinds _binds) = return Nothing foldHsLocalBindsLR EmptyLocalBinds = return Nothing -foldHsValBindsLR :: HsValBindsLR Id Var -> State ASTState (Maybe Type) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldHsValBindsLR :: HsValBindsLR GhcTc GhcTc -> State ASTState (Maybe Type) +#endif foldHsValBindsLR (ValBindsIn _ _) = return Nothing foldHsValBindsLR (ValBindsOut binds _) = do _ <- mapM_ (foldLHsBindsLR . snd) binds return Nothing -foldLHsBindsLR :: LHsBinds Id -> State ASTState () +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldLHsBindsLR :: LHsBinds GhcTc -> State ASTState () +#endif foldLHsBindsLR = mapM_ (`foldLHsBindLR` Nothing) . bagToList -foldLHsBindLR :: LHsBindLR Id Var +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldLHsBindLR :: LHsBindLR GhcTc GhcTc -> Maybe Id -- ^ Polymorphic id -> State ASTState (Maybe Type) +#endif foldLHsBindLR (L _span FunBind {..}) mbPolyId | mg_origin fun_matches == FromSource = restoreTidyEnv $ do @@ -1024,12 +1068,17 @@ foldLHsBindLR (L _ AbsBinds {..}) _ = do mapM_ (\(bind, typ) -> foldLHsBindLR bind (Just typ)) $ zip (bagToList abs_binds) (map abe_poly abs_exports) return Nothing +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +#else foldLHsBindLR (L _ AbsBindsSig {..}) _ = do _ <- foldLHsBindLR abs_sig_bind (Just abs_sig_export) return Nothing +#endif foldLHsBindLR (L _ (PatSynBind PSB {..})) _ = restoreTidyEnv $ do _ <- foldLPat psb_def +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +#else _ <- let addId :: GenLocated SrcSpan Id -> State ASTState () addId (L span i) = do @@ -1043,9 +1092,12 @@ foldLHsBindLR (L _ (PatSynBind PSB {..})) _ = (\(RecordPatSynField selId patVar) -> addId selId >> addId patVar) recs +#endif return Nothing -foldLPat :: LPat Id -> State ASTState (Maybe Type) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldLPat :: LPat GhcTc -> State ASTState (Maybe Type) +#endif foldLPat (L span (VarPat (L _ identifier))) = do (identifier', _) <- tidyIdentifier identifier addIdentifierToIdSrcSpanMap span identifier' Nothing @@ -1151,9 +1203,11 @@ foldLPat (L span p@(CoPat _ pat typ)) = do _ <- foldLPat (L span pat) return Nothing +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldHsConPatDetails - :: HsConPatDetails Id + :: HsConPatDetails GhcTc -> State ASTState (Maybe Type) +#endif foldHsConPatDetails (PrefixCon args) = do _ <- mapM_ foldLPat args return Nothing @@ -1165,7 +1219,9 @@ foldHsConPatDetails (InfixCon arg1 arg2) = do _ <- foldLPat arg2 return Nothing -foldHsRecFieldsPat :: HsRecFields Id (LPat Id) -> State ASTState (Maybe Type) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldHsRecFieldsPat :: HsRecFields GhcTc (LPat GhcTc) -> State ASTState (Maybe Type) +#endif foldHsRecFieldsPat HsRecFields {..} = do let onlyUserWritten = case rec_dotdot of @@ -1174,20 +1230,26 @@ foldHsRecFieldsPat HsRecFields {..} = do _ <- mapM_ foldLHsRecFieldPat $ onlyUserWritten rec_flds return Nothing -foldLHsRecFieldPat :: LHsRecField Id (LPat Id) -> State ASTState (Maybe Type) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldLHsRecFieldPat :: LHsRecField GhcTc (LPat GhcTc) -> State ASTState (Maybe Type) +#endif 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' -foldLHsCmdTop :: LHsCmdTop Id -> State ASTState (Maybe Type) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldLHsCmdTop :: LHsCmdTop GhcTc -> State ASTState (Maybe Type) +#endif foldLHsCmdTop (L span (HsCmdTop cmd _ _ _)) = do mbTyp <- foldLHsCmd cmd addExprInfo span mbTyp "HsCmdTop" Composite return mbTyp -foldLHsCmd :: LHsCmd Id -> State ASTState (Maybe Type) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +foldLHsCmd :: LHsCmd GhcTc -> State ASTState (Maybe Type) +#endif foldLHsCmd (L _ (HsCmdArrApp expr1 expr2 _ _ _)) = do _ <- foldLHsExpr expr1 _ <- foldLHsExpr expr2 diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs index 714e429..09be369 100644 --- a/src/HaskellCodeExplorer/GhcUtils.hs +++ b/src/HaskellCodeExplorer/GhcUtils.hs @@ -3,6 +3,8 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} module HaskellCodeExplorer.GhcUtils @@ -138,11 +140,18 @@ import GHC , tyFamInstDeclName , idType , hsib_body +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +#else , tfe_pats +#endif , tfid_eqn ) + import qualified HaskellCodeExplorer.Types as HCE import HscTypes (TypeEnv, lookupTypeEnv) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +import HsExtension (GhcPs, GhcRn, GhcTc, IdP(..), Pass(..)) +#endif import IdInfo (IdDetails(..)) import InstEnv (ClsInst(..)) import Lexer (ParseResult(POk), mkPState, unP) @@ -250,9 +259,12 @@ instanceToText :: DynFlags -> ClsInst -> T.Text instanceToText flags ClsInst {..} = T.append "instance " $ T.pack . showSDoc flags $ pprSigmaType (idType is_dfun) -instanceDeclToText :: DynFlags -> InstDecl Name -> T.Text +--instanceDeclToText :: DynFlags -> InstDecl Name -> T.Text instanceDeclToText flags decl = case decl of +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + _ -> "" +#else ClsInstD ClsInstDecl {..} -> T.append "instance " (toText flags cid_poly_ty) DataFamInstD di -> let args = @@ -266,6 +278,7 @@ instanceDeclToText flags decl = ti in T.concat ["type instance ", toText flags $ tyFamInstDeclName ti, " ", args] +#endif nameToText :: Name -> T.Text nameToText = T.pack . unpackFS . occNameFS . nameOccName @@ -366,7 +379,9 @@ mbIdDetails _ = Nothing -- Syntax transformation -------------------------------------------------------------------------------- -hsGroupVals :: HsGroup Name -> [GenLocated SrcSpan (HsBindLR Name Name)] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +hsGroupVals :: HsGroup GhcRn -> [GenLocated SrcSpan (HsBindLR GhcRn GhcRn)] +#endif hsGroupVals hsGroup = filter (isGoodSrcSpan . getLoc) $ case hs_valds hsGroup of @@ -375,6 +390,9 @@ hsGroupVals hsGroup = hsPatSynDetails :: HsPatSynDetails a -> [a] hsPatSynDetails patDetails = +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + [] +#else case patDetails of InfixPatSyn name1 name2 -> [name1, name2] PrefixPatSyn name -> name @@ -382,8 +400,13 @@ hsPatSynDetails patDetails = concatMap (\field -> [recordPatSynSelectorId field, recordPatSynPatVar field]) fields +#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +--unwrapName :: LIEWrappedName n -> Located n +unwrapName = ieLWrappedName +#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) unwrapName :: LIEWrappedName Name -> Located Name unwrapName = ieLWrappedName #else @@ -391,7 +414,7 @@ unwrapName :: Located Name -> Located Name unwrapName n = n #endif -ieLocNames :: IE Name -> [Located Name] +--ieLocNames :: IE (IdP GhcTc) -> [Located Name] ieLocNames (IEVar n) = [unwrapName n] ieLocNames (IEThingAbs n) = [unwrapName n] ieLocNames (IEThingAll n) = [unwrapName n] @@ -909,7 +932,7 @@ collectDocs = go Nothing [] go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) finished decl docs rest = (decl, reverse docs) : rest -ungroup :: HsGroup Name -> [LHsDecl Name] +--ungroup :: HsGroup Name -> [LHsDecl Name] ungroup group_ = #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ @@ -939,7 +962,7 @@ mkDecls field con struct = [L loc (con decl) | L loc decl <- field struct] sortByLoc :: [Located a] -> [Located a] sortByLoc = L.sortBy (comparing getLoc) -classDeclDocs :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])] +--classDeclDocs :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])] classDeclDocs class_ = collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats @@ -948,13 +971,13 @@ classDeclDocs class_ = collectDocs . sortByLoc $ decls sigs = mkDecls tcdSigs SigD class_ ats = mkDecls tcdATs (TyClD . FamDecl) class_ -conDeclDocs :: ConDecl Name -> [(Name, [HsDocString], SrcSpan)] +--conDeclDocs :: ConDecl Name -> [(Name, [HsDocString], SrcSpan)] conDeclDocs conDecl = map (\(L span n) -> (n, maybe [] ((: []) . unLoc) $ con_doc conDecl, span)) . getConNames $ conDecl -selectorDocs :: ConDecl name -> [(PostRn name name, [HsDocString], SrcSpan)] +--selectorDocs :: ConDecl name -> [(PostRn name name, [HsDocString], SrcSpan)] selectorDocs con = case getConDetails con of RecCon (L _ flds) -> @@ -967,9 +990,14 @@ selectorDocs con = flds _ -> [] -subordinateNamesWithDocs :: - [GenLocated SrcSpan (HsDecl Name)] -> [(Name, [HsDocString], SrcSpan)] -subordinateNamesWithDocs = + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +subordinateNamesWithDocs :: [GenLocated SrcSpan (HsDecl GhcRn)] -> [(Name, [HsDocString], SrcSpan)] +#endif +subordinateNamesWithDocs _ = +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + [] +#else concatMap (\(L span tyClDecl) -> case tyClDecl of @@ -983,13 +1011,14 @@ subordinateNamesWithDocs = InstD (DataFamInstD DataFamInstDecl {..}) -> concatMap (conDeclDocs . unLoc) . dd_cons $ dfid_defn _ -> []) +#endif isUserLSig :: LSig name -> Bool isUserLSig (L _ TypeSig {}) = True isUserLSig (L _ ClassOpSig {}) = True isUserLSig _ = False -getMainDeclBinder :: HsDecl name -> [name] +--getMainDeclBinder :: HsDecl name -> [name] getMainDeclBinder (TyClD d) = [tcdName d] getMainDeclBinder (ValD d) = case collectHsBindBinders d of @@ -1000,7 +1029,7 @@ getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] getMainDeclBinder (ForD ForeignExport {}) = [] getMainDeclBinder _ = [] -sigNameNoLoc :: Sig name -> [name] +--sigNameNoLoc :: Sig name -> [name] sigNameNoLoc (TypeSig ns _) = map unLoc ns sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) @@ -1108,6 +1137,7 @@ outOfScope dflags x = 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 diff --git a/src/HaskellCodeExplorer/ModuleInfo.hs b/src/HaskellCodeExplorer/ModuleInfo.hs index cc81a36..5145fa5 100644 --- a/src/HaskellCodeExplorer/ModuleInfo.hs +++ b/src/HaskellCodeExplorer/ModuleInfo.hs @@ -23,8 +23,9 @@ import qualified Data.Map.Strict as M import qualified Data.IntMap.Strict as IM import qualified Data.IntervalMap.Strict as IVM import qualified Data.List as L hiding (span) -import Data.Maybe(fromMaybe,mapMaybe) -import Data.Ord(comparing) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Ord (comparing) +import HsExtension (GhcRn) import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -307,10 +308,17 @@ createDefinitionSiteMap :: -> HCE.SourceCodeTransformation -> ModuleInfo -> [Name] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + -> HsGroup GhcRn +#else -> HsGroup Name +#endif -> (HCE.DefinitionSiteMap, [Name]) createDefinitionSiteMap flags currentPackageId compId defSiteMap fileMap globalRdrEnv transformation modInfo dataFamTyCons hsGroup = - let allDecls :: [GenLocated SrcSpan (HsDecl Name)] + let +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + allDecls :: [GenLocated SrcSpan (HsDecl GhcRn)] +#endif allDecls = L.sortBy (comparing getLoc) . ungroup $ hsGroup (instanceDeclsWithDocs, valueAndTypeDeclsWithDocs) = L.partition @@ -465,7 +473,9 @@ docWithNamesToHtml flags packageId compId transformation fileMap defSiteMap = createDeclarations :: DynFlags - -> HsGroup Name +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + -> HsGroup GhcRn +#endif -> TypeEnv -> S.Set Name -> HCE.SourceCodeTransformation @@ -483,8 +493,9 @@ createDeclarations flags hsGroup typeEnv exportedSet transformation = Nothing -> Nothing -- | Top-level functions -------------------------------------------------------------------------------- - valToDeclarations :: - GenLocated SrcSpan (HsBindLR Name Name) -> [HCE.Declaration] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + valToDeclarations :: GenLocated SrcSpan (HsBindLR GhcRn GhcRn) -> [HCE.Declaration] +#endif valToDeclarations (L loc bind) = map (\name -> @@ -498,7 +509,9 @@ createDeclarations flags hsGroup typeEnv exportedSet transformation = vals = concatMap valToDeclarations $ hsGroupVals hsGroup -- | Data, newtype, type, type family, data family or class declaration -------------------------------------------------------------------------------- - tyClToDeclaration :: GenLocated SrcSpan (TyClDecl Name) -> HCE.Declaration +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + tyClToDeclaration :: GenLocated SrcSpan (TyClDecl GhcRn) -> HCE.Declaration +#endif tyClToDeclaration (L loc tyClDecl) = HCE.Declaration HCE.TyClD @@ -512,7 +525,9 @@ createDeclarations flags hsGroup typeEnv exportedSet transformation = hsGroup -- | Instances -------------------------------------------------------------------------------- - instToDeclaration :: GenLocated SrcSpan (InstDecl Name) -> HCE.Declaration +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + instToDeclaration :: GenLocated SrcSpan (InstDecl GhcRn) -> HCE.Declaration +#endif instToDeclaration (L loc inst) = HCE.Declaration HCE.InstD @@ -529,8 +544,10 @@ createDeclarations flags hsGroup typeEnv exportedSet transformation = hsGroup -- | Foreign functions -------------------------------------------------------------------------------- +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foreignFunToDeclaration :: - GenLocated SrcSpan (ForeignDecl Name) -> HCE.Declaration + GenLocated SrcSpan (ForeignDecl GhcRn) -> HCE.Declaration +#endif foreignFunToDeclaration (L loc fd) = let name = unLoc $ fd_name fd in HCE.Declaration @@ -588,7 +605,11 @@ foldAST environment typecheckedModule = case mbExported of Just lieNames -> mapMaybe +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + (\(L span ie,_) -> +#else (\(L span ie) -> +#endif case ie of IEModuleContents (L _ modName) -> Just -- cgit v1.2.3 From c6fc26d897b147d5ac48d0d799230c5a4ddb791d Mon Sep 17 00:00:00 2001 From: alexwl Date: Fri, 12 Oct 2018 19:45:12 +0300 Subject: Fix all GHC 8.4.3 compatibility issues. Needs a bit more testing. --- src/HaskellCodeExplorer/AST/RenamedSource.hs | 72 ++++++++++++--- src/HaskellCodeExplorer/AST/TypecheckedSource.hs | 79 ++++++++++++++-- src/HaskellCodeExplorer/GhcUtils.hs | 110 ++++++++++++++++++----- src/HaskellCodeExplorer/ModuleInfo.hs | 5 ++ src/HaskellCodeExplorer/Types.hs | 20 ++++- stack.yaml | 2 +- test/Main.hs | 24 +++-- test/test-package/stack-8.2.2.yaml | 1 + test/test-package/stack.yaml | 2 +- 9 files changed, 265 insertions(+), 50 deletions(-) create mode 100644 test/test-package/stack-8.2.2.yaml (limited to 'src/HaskellCodeExplorer') diff --git a/src/HaskellCodeExplorer/AST/RenamedSource.hs b/src/HaskellCodeExplorer/AST/RenamedSource.hs index ea5a87a..592c8f7 100644 --- a/src/HaskellCodeExplorer/AST/RenamedSource.hs +++ b/src/HaskellCodeExplorer/AST/RenamedSource.hs @@ -56,6 +56,8 @@ import GHC , Sig(..) , TyClDecl(..) #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + , FamEqn(..) + , HsDataDefn(..) #else , TyFamEqn(..) #endif @@ -94,6 +96,8 @@ namesFromRenamedSource = tyClDeclNames `extQ` familyDeclNames `extQ` #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + familyEqNames `extQ` + dataEqNames `extQ` #else tyFamilyEqNames `extQ` tyFamilyDefEqNames `extQ` @@ -111,6 +115,8 @@ namesFromRenamedSource = #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) fieldOccName :: Bool -> FieldOcc GhcRn -> NameOccurrence +#else +fieldOccName :: Bool -> FieldOcc Name -> NameOccurrence #endif fieldOccName isBinder (FieldOcc (L span _) name) = NameOccurrence @@ -121,17 +127,23 @@ fieldOccName isBinder (FieldOcc (L span _) name) = #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) conDeclFieldNames :: ConDeclField GhcRn -> [NameOccurrence] +#else +conDeclFieldNames :: ConDeclField Name -> [NameOccurrence] #endif conDeclFieldNames ConDeclField {..} = map (fieldOccName True . unLoc) cd_fld_names #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) hsRecFieldExprNames :: HsRecField' (FieldOcc GhcRn) (LHsExpr GhcRn) -> [NameOccurrence] +#else +hsRecFieldExprNames :: HsRecField' (FieldOcc Name) (LHsExpr Name) -> [NameOccurrence] #endif hsRecFieldExprNames HsRecField {..} = [fieldOccName False $ unLoc hsRecFieldLbl] #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) hsRecAmbFieldExprNames :: HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn) -> [NameOccurrence] +#else +hsRecAmbFieldExprNames :: HsRecField' (AmbiguousFieldOcc Name) (LHsExpr Name) -> [NameOccurrence] #endif hsRecAmbFieldExprNames HsRecField {..} = let (L span recField) = hsRecFieldLbl @@ -148,11 +160,15 @@ hsRecAmbFieldExprNames HsRecField {..} = #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) hsRecFieldPatNames :: HsRecField' (FieldOcc GhcRn) (LPat GhcRn) -> [NameOccurrence] -#endif +#else +hsRecFieldPatNames :: HsRecField' (FieldOcc Name) (LPat Name) -> [NameOccurrence] +#endif hsRecFieldPatNames HsRecField {..} = [fieldOccName False $ unLoc hsRecFieldLbl] #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) hsExprNames :: LHsExpr GhcRn -> [NameOccurrence] +#else +hsExprNames :: LHsExpr Name -> [NameOccurrence] #endif hsExprNames (L _span (HsVar name)) = [ NameOccurrence @@ -195,9 +211,11 @@ hsExprNames _ = [] #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) matchGroupNames :: MatchGroup GhcRn (LHsExpr GhcRn) -> [NameOccurrence] +#else +matchGroupNames :: MatchGroup Name (LHsExpr Name) -> [NameOccurrence] #endif matchGroupNames = -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) +#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) mapMaybe (fmap toNameOcc . matchContextName . m_ctxt . unLoc) . #else mapMaybe (fmap toNameOcc . matchFixityName . m_fixity . unLoc) . @@ -216,10 +234,12 @@ matchGroupNames = --toNameOcc :: Located Name -> NameOccurrence toNameOcc n = NameOccurrence - {locatedName = Just <$> n, description = "Match", isBinder = True} + {locatedName = Just <$> n, description = "Match", isBinder = True} #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) bindNames :: LHsBindLR GhcRn GhcRn -> [NameOccurrence] +#else +bindNames :: LHsBindLR Name Name -> [NameOccurrence] #endif bindNames (L _span (PatSynBind PSB {..})) = [ NameOccurrence @@ -230,6 +250,7 @@ bindNames (L _span (PatSynBind PSB {..})) = ] bindNames _ = [] +hsPatSynDetailsNames :: HsPatSynDetails (Located Name) -> [NameOccurrence] hsPatSynDetailsNames = map (\name -> @@ -240,9 +261,10 @@ hsPatSynDetailsNames = }) . hsPatSynDetails - #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) importNames :: IE GhcRn -> [NameOccurrence] +#else +importNames :: IE Name -> [NameOccurrence] #endif importNames = map @@ -257,6 +279,8 @@ importNames = #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) patNames :: LPat GhcRn -> [NameOccurrence] +#else +patNames :: LPat Name -> [NameOccurrence] #endif patNames (L _span (VarPat name)) = [ NameOccurrence @@ -291,6 +315,8 @@ patNames _ = [] #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) sigNames :: LSig GhcRn -> [NameOccurrence] +#else +sigNames :: LSig Name -> [NameOccurrence] #endif sigNames (L _span (TypeSig names _)) = map @@ -363,9 +389,10 @@ sigNames (L _span (MinimalSig _ (L _ boolFormula))) = boolFormulaNames (Parens (L _ f)) = boolFormulaNames f sigNames (L _ _) = [] - #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) hsTypeNames :: LHsType GhcRn -> [NameOccurrence] +#else +hsTypeNames :: LHsType Name -> [NameOccurrence] #endif #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) hsTypeNames (L _span (HsTyVar _promoted name)) = @@ -419,6 +446,8 @@ hsTypeNames _ = [] #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) hsTyVarBndrNames :: HsTyVarBndr GhcRn -> [NameOccurrence] +#else +hsTyVarBndrNames :: HsTyVarBndr Name -> [NameOccurrence] #endif hsTyVarBndrNames (UserTyVar n) = [ NameOccurrence @@ -437,6 +466,8 @@ hsTyVarBndrNames (KindedTyVar n _) = #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) tyClDeclNames :: LTyClDecl GhcRn -> [NameOccurrence] +#else +tyClDeclNames :: LTyClDecl Name -> [NameOccurrence] #endif tyClDeclNames (L _span DataDecl {..}) = [ NameOccurrence @@ -473,6 +504,8 @@ tyClDeclNames _ = [] #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) familyDeclNames :: FamilyDecl GhcRn -> [NameOccurrence] +#else +familyDeclNames :: FamilyDecl Name -> [NameOccurrence] #endif familyDeclNames FamilyDecl {..} = [ NameOccurrence @@ -483,10 +516,26 @@ familyDeclNames FamilyDecl {..} = ] ---TODO #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +familyEqNames :: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn) -> [NameOccurrence] +familyEqNames FamEqn {feqn_tycon = tyCon} = + [ NameOccurrence + { locatedName = Just <$> tyCon + , description = "FamEqn" + , isBinder = False + } + ] + +dataEqNames :: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn) -> [NameOccurrence] +dataEqNames FamEqn {feqn_tycon = tyCon} = + [ NameOccurrence + { locatedName = Just <$> tyCon + , description = "FamEqn" + , isBinder = False + } + ] #else ---tyFamilyEqNames :: TyFamEqn Name (HsTyPats Name) -> [NameOccurrence] +tyFamilyEqNames :: TyFamEqn Name (HsTyPats Name) -> [NameOccurrence] tyFamilyEqNames TyFamEqn {tfe_tycon = tyCon} = [ NameOccurrence { locatedName = Just <$> tyCon @@ -495,7 +544,7 @@ tyFamilyEqNames TyFamEqn {tfe_tycon = tyCon} = } ] ---tyFamilyDefEqNames :: TyFamEqn Name (LHsQTyVars Name) -> [NameOccurrence] +tyFamilyDefEqNames :: TyFamEqn Name (LHsQTyVars Name) -> [NameOccurrence] tyFamilyDefEqNames TyFamEqn {tfe_tycon = tyCon} = [ NameOccurrence { locatedName = Just <$> tyCon @@ -504,8 +553,7 @@ tyFamilyDefEqNames TyFamEqn {tfe_tycon = tyCon} = } ] - ---dataFamInstDeclNames :: DataFamInstDecl Name -> [NameOccurrence] +dataFamInstDeclNames :: DataFamInstDecl Name -> [NameOccurrence] dataFamInstDeclNames DataFamInstDecl {dfid_tycon = tyCon} = [ NameOccurrence { locatedName = Just <$> tyCon @@ -517,6 +565,8 @@ dataFamInstDeclNames DataFamInstDecl {dfid_tycon = tyCon} = #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) conDeclNames :: ConDecl GhcRn -> [NameOccurrence] +#else +conDeclNames :: ConDecl Name -> [NameOccurrence] #endif conDeclNames con = case con of @@ -539,6 +589,8 @@ conDeclNames con = #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foreignDeclNames :: ForeignDecl GhcRn -> [NameOccurrence] +#else +foreignDeclNames :: ForeignDecl Name -> [NameOccurrence] #endif foreignDeclNames decl = [ NameOccurrence diff --git a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs index 4dfbd8b..6f9a4cf 100644 --- a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs +++ b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs @@ -80,7 +80,9 @@ import HsSyn , selectorAmbiguousFieldOcc ) import HscTypes (TypeEnv, lookupTypeEnv) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) import HsExtension (GhcTc) +#endif import Id (idType) import IdInfo (IdDetails(..)) import InstEnv @@ -545,11 +547,15 @@ tidyType typ = do #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldTypecheckedSource :: LHsBinds GhcTc -> State ASTState () +#else +foldTypecheckedSource :: LHsBinds Id -> State ASTState () #endif foldTypecheckedSource = foldLHsBindsLR #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLHsExpr :: LHsExpr GhcTc -> State ASTState (Maybe Type) +#else +foldLHsExpr :: LHsExpr Id -> State ASTState (Maybe Type) #endif foldLHsExpr (L span (HsVar (L _ identifier))) = restoreTidyEnv $ do @@ -809,6 +815,8 @@ foldLHsExpr (L span (HsWrap wrapper expr)) = #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldHsRecFields :: HsRecFields GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +#else +foldHsRecFields :: HsRecFields Id (LHsExpr Id) -> State ASTState (Maybe Type) #endif foldHsRecFields HsRecFields {..} = do let userWritten = @@ -820,6 +828,8 @@ foldHsRecFields HsRecFields {..} = do #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 (L span (HsRecField (L idSpan (FieldOcc _ identifier)) arg pun)) = restoreTidyEnv $ do @@ -831,6 +841,8 @@ foldLHsRecField (L span (HsRecField (L idSpan (FieldOcc _ identifier)) arg pun)) #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLHsRecUpdField :: LHsRecUpdField GhcTc -> State ASTState (Maybe Type) +#else +foldLHsRecUpdField :: LHsRecUpdField Id -> State ASTState (Maybe Type) #endif foldLHsRecUpdField (L span (HsRecField (L idSpan recField) arg pun)) = restoreTidyEnv $ do @@ -857,6 +869,8 @@ data TupArg #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLHsTupArg :: LHsTupArg GhcTc -> State ASTState (Maybe Type, TupArg) +#else +foldLHsTupArg :: LHsTupArg Id -> State ASTState (Maybe Type, TupArg) #endif foldLHsTupArg (L _span (Present expr)) = restoreTidyEnv $ do @@ -873,6 +887,8 @@ foldLHsTupArg (L _ (Missing typ)) = #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLMatch :: LMatch GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +#else +foldLMatch :: LMatch Id (LHsExpr Id) -> State ASTState (Maybe Type) #endif foldLMatch (L _span Match {..}) = do mapM_ foldLPat m_pats @@ -881,6 +897,8 @@ foldLMatch (L _span Match {..}) = do #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLMatchCmd :: LMatch GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type) +#else +foldLMatchCmd :: LMatch Id (LHsCmd Id) -> State ASTState (Maybe Type) #endif foldLMatchCmd (L _span Match {..}) = do mapM_ foldLPat m_pats @@ -889,6 +907,8 @@ foldLMatchCmd (L _span Match {..}) = do #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldGRHSsCmd :: GRHSs GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type) +#else +foldGRHSsCmd :: GRHSs Id (LHsCmd Id) -> State ASTState (Maybe Type) #endif foldGRHSsCmd GRHSs {..} = do mapM_ foldLGRHSCmd grhssGRHSs @@ -897,6 +917,8 @@ foldGRHSsCmd GRHSs {..} = do #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldGRHSs :: GRHSs GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +#else +foldGRHSs :: GRHSs Id (LHsExpr Id) -> State ASTState (Maybe Type) #endif foldGRHSs GRHSs {..} = do mapM_ foldLGRHS grhssGRHSs @@ -905,6 +927,8 @@ foldGRHSs GRHSs {..} = do #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLStmtLR :: LStmtLR GhcTc GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +#else +foldLStmtLR :: LStmtLR Id Id (LHsExpr Id) -> State ASTState (Maybe Type) #endif foldLStmtLR (L span (LastStmt body _ _)) = do typ <- foldLHsExpr body @@ -941,6 +965,8 @@ foldLStmtLR (L span (ApplicativeStmt args _ typ)) = #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldApplicativeArg :: ApplicativeArg GhcTc GhcTc -> State ASTState (Maybe Type) +#else +foldApplicativeArg :: ApplicativeArg Id Id -> State ASTState (Maybe Type) #endif foldApplicativeArg appArg = case appArg of @@ -957,8 +983,10 @@ foldApplicativeArg appArg = _ <- foldLPat pat return Nothing #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -foldLStmtLRCmd :: LStmtLR GhcTc GhcTc (LHsCmd GhcTc) - -> State ASTState (Maybe Type) +foldLStmtLRCmd :: + LStmtLR GhcTc GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type) +#else +foldLStmtLRCmd :: LStmtLR Id Id (LHsCmd Id) -> State ASTState (Maybe Type) #endif foldLStmtLRCmd (L span (LastStmt body _syntaxExpr _)) = do typ <- foldLHsCmd body @@ -995,6 +1023,8 @@ foldLStmtLRCmd (L span (ApplicativeStmt args _ typ)) = #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLGRHS :: LGRHS GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +#else +foldLGRHS :: LGRHS Id (LHsExpr Id) -> State ASTState (Maybe Type) #endif foldLGRHS (L _span (GRHS guards body)) = do typ <- foldLHsExpr body @@ -1003,14 +1033,18 @@ foldLGRHS (L _span (GRHS guards body)) = do #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLGRHSCmd :: LGRHS GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type) +#else +foldLGRHSCmd :: LGRHS Id (LHsCmd Id) -> State ASTState (Maybe Type) #endif foldLGRHSCmd (L _span (GRHS guards body)) = do typ <- foldLHsCmd body mapM_ foldLStmtLR guards return typ -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldParStmtBlock :: ParStmtBlock GhcTc GhcTc -> State ASTState (Maybe Type) +#else +foldParStmtBlock :: ParStmtBlock Id Id -> State ASTState (Maybe Type) #endif foldParStmtBlock (ParStmtBlock exprStmts _ids _syntaxExpr) = do mapM_ foldLStmtLR exprStmts @@ -1018,6 +1052,8 @@ foldParStmtBlock (ParStmtBlock exprStmts _ids _syntaxExpr) = do #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldHsLocalBindsLR :: HsLocalBindsLR GhcTc GhcTc -> State ASTState (Maybe Type) +#else +foldHsLocalBindsLR :: HsLocalBindsLR Id Id -> State ASTState (Maybe Type) #endif foldHsLocalBindsLR (HsValBinds binds) = do _ <- foldHsValBindsLR binds @@ -1027,6 +1063,8 @@ foldHsLocalBindsLR EmptyLocalBinds = return Nothing #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldHsValBindsLR :: HsValBindsLR GhcTc GhcTc -> State ASTState (Maybe Type) +#else +foldHsValBindsLR :: HsValBindsLR Id Id -> State ASTState (Maybe Type) #endif foldHsValBindsLR (ValBindsIn _ _) = return Nothing foldHsValBindsLR (ValBindsOut binds _) = do @@ -1035,6 +1073,8 @@ foldHsValBindsLR (ValBindsOut binds _) = do #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLHsBindsLR :: LHsBinds GhcTc -> State ASTState () +#else +foldLHsBindsLR :: LHsBinds Id -> State ASTState () #endif foldLHsBindsLR = mapM_ (`foldLHsBindLR` Nothing) . bagToList @@ -1042,7 +1082,11 @@ foldLHsBindsLR = mapM_ (`foldLHsBindLR` Nothing) . bagToList foldLHsBindLR :: LHsBindLR GhcTc GhcTc -> Maybe Id -- ^ Polymorphic id -> State ASTState (Maybe Type) -#endif +#else +foldLHsBindLR :: LHsBindLR Id Id + -> Maybe Id -- ^ Polymorphic id + -> State ASTState (Maybe Type) +#endif foldLHsBindLR (L _span FunBind {..}) mbPolyId | mg_origin fun_matches == FromSource = restoreTidyEnv $ do @@ -1077,26 +1121,35 @@ foldLHsBindLR (L _ AbsBindsSig {..}) _ = do foldLHsBindLR (L _ (PatSynBind PSB {..})) _ = restoreTidyEnv $ do _ <- foldLPat psb_def -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -#else _ <- let addId :: GenLocated SrcSpan Id -> State ASTState () addId (L span i) = do (i', _) <- tidyIdentifier i addIdentifierToIdSrcSpanMap span i' Nothing in case psb_args of +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + InfixCon id1 id2 -> addId id1 >> addId id2 + PrefixCon ids -> mapM_ addId ids + RecCon recs -> + mapM_ + (\(RecordPatSynField selId patVar) -> + addId selId >> addId patVar) + recs +#else InfixPatSyn id1 id2 -> addId id1 >> addId id2 PrefixPatSyn ids -> mapM_ addId ids RecordPatSyn recs -> mapM_ (\(RecordPatSynField selId patVar) -> addId selId >> addId patVar) - recs + recs #endif return Nothing #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLPat :: LPat GhcTc -> State ASTState (Maybe Type) +#else +foldLPat :: LPat Id -> State ASTState (Maybe Type) #endif foldLPat (L span (VarPat (L _ identifier))) = do (identifier', _) <- tidyIdentifier identifier @@ -1207,6 +1260,10 @@ foldLPat (L span p@(CoPat _ pat typ)) = do foldHsConPatDetails :: HsConPatDetails GhcTc -> State ASTState (Maybe Type) +#else +foldHsConPatDetails + :: HsConPatDetails Id + -> State ASTState (Maybe Type) #endif foldHsConPatDetails (PrefixCon args) = do _ <- mapM_ foldLPat args @@ -1221,6 +1278,8 @@ foldHsConPatDetails (InfixCon arg1 arg2) = do #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldHsRecFieldsPat :: HsRecFields GhcTc (LPat GhcTc) -> State ASTState (Maybe Type) +#else +foldHsRecFieldsPat :: HsRecFields Id (LPat Id) -> State ASTState (Maybe Type) #endif foldHsRecFieldsPat HsRecFields {..} = do let onlyUserWritten = @@ -1232,6 +1291,8 @@ foldHsRecFieldsPat HsRecFields {..} = do #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLHsRecFieldPat :: LHsRecField GhcTc (LPat GhcTc) -> State ASTState (Maybe Type) +#else +foldLHsRecFieldPat :: LHsRecField Id (LPat Id) -> State ASTState (Maybe Type) #endif foldLHsRecFieldPat (L _ (HsRecField (L idSpan (FieldOcc _ identifier)) arg pun)) = do (identifier', mbTypes) <- tidyIdentifier identifier @@ -1241,6 +1302,8 @@ foldLHsRecFieldPat (L _ (HsRecField (L idSpan (FieldOcc _ identifier)) arg pun)) #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLHsCmdTop :: LHsCmdTop GhcTc -> State ASTState (Maybe Type) +#else +foldLHsCmdTop :: LHsCmdTop Id -> State ASTState (Maybe Type) #endif foldLHsCmdTop (L span (HsCmdTop cmd _ _ _)) = do mbTyp <- foldLHsCmd cmd @@ -1249,6 +1312,8 @@ foldLHsCmdTop (L span (HsCmdTop cmd _ _ _)) = do #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldLHsCmd :: LHsCmd GhcTc -> State ASTState (Maybe Type) +#else +foldLHsCmd :: LHsCmd Id -> State ASTState (Maybe Type) #endif foldLHsCmd (L _ (HsCmdArrApp expr1 expr2 _ _ _)) = do _ <- foldLHsExpr expr1 diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs index 09be369..b25678d 100644 --- a/src/HaskellCodeExplorer/GhcUtils.hs +++ b/src/HaskellCodeExplorer/GhcUtils.hs @@ -73,7 +73,13 @@ import Data.Ord (comparing) import qualified Data.Text as T import DataCon (dataConWorkId, flSelector) import Documentation.Haddock.Parser (overIdentifier, parseParas) -import Documentation.Haddock.Types (DocH(..), Header(..), _doc) +import Documentation.Haddock.Types (DocH(..), + Header(..), + _doc, +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + Table(..) +#endif + ) import DynFlags () import FastString (mkFastString, unpackFS) import GHC @@ -122,6 +128,9 @@ import GHC , ieLWrappedName #else , tyClGroupConcat +#endif +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + , FamEqn(..) #endif , tyConKind , nameSrcSpan @@ -150,7 +159,7 @@ import GHC import qualified HaskellCodeExplorer.Types as HCE import HscTypes (TypeEnv, lookupTypeEnv) #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -import HsExtension (GhcPs, GhcRn, GhcTc, IdP(..), Pass(..)) +import HsExtension (GhcRn,IdP) #endif import IdInfo (IdDetails(..)) import InstEnv (ClsInst(..)) @@ -259,13 +268,28 @@ instanceToText :: DynFlags -> ClsInst -> T.Text instanceToText flags ClsInst {..} = T.append "instance " $ T.pack . showSDoc flags $ pprSigmaType (idType is_dfun) ---instanceDeclToText :: DynFlags -> InstDecl Name -> T.Text +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +instanceDeclToText :: DynFlags -> InstDecl GhcRn -> T.Text +#else +instanceDeclToText :: DynFlags -> InstDecl Name -> T.Text +#endif instanceDeclToText flags decl = case decl of -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) - _ -> "" -#else ClsInstD ClsInstDecl {..} -> T.append "instance " (toText flags cid_poly_ty) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + DataFamInstD di -> + let args = + T.intercalate " " . map (toText flags) . feqn_pats .hsib_body . dfid_eqn $ di + in T.concat + ["data instance ", toText flags (unLoc $ feqn_tycon . hsib_body . dfid_eqn $ di), " ", args] + TyFamInstD ti -> + let args = + T.intercalate " " . + map (toText flags) . feqn_pats . hsib_body . tfid_eqn $ + ti + in T.concat + ["type instance ", toText flags $ tyFamInstDeclName ti, " ", args] +#else DataFamInstD di -> let args = T.intercalate " " . map (toText flags) . hsib_body $ dfid_pats di @@ -381,6 +405,8 @@ mbIdDetails _ = Nothing #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) hsGroupVals :: HsGroup GhcRn -> [GenLocated SrcSpan (HsBindLR GhcRn GhcRn)] +#else +hsGroupVals :: HsGroup Name -> [GenLocated SrcSpan (HsBindLR Name Name)] #endif hsGroupVals hsGroup = filter (isGoodSrcSpan . getLoc) $ @@ -391,7 +417,12 @@ hsGroupVals hsGroup = hsPatSynDetails :: HsPatSynDetails a -> [a] hsPatSynDetails patDetails = #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) - [] + case patDetails of + InfixCon name1 name2 -> [name1, name2] + PrefixCon fields -> fields + RecCon fields -> concatMap + (\field -> [recordPatSynSelectorId field, recordPatSynPatVar field]) + fields #else case patDetails of InfixPatSyn name1 name2 -> [name1, name2] @@ -404,7 +435,7 @@ hsPatSynDetails patDetails = #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) ---unwrapName :: LIEWrappedName n -> Located n +unwrapName :: LIEWrappedName a -> Located a unwrapName = ieLWrappedName #elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) unwrapName :: LIEWrappedName Name -> Located Name @@ -414,7 +445,11 @@ unwrapName :: Located Name -> Located Name unwrapName n = n #endif ---ieLocNames :: IE (IdP GhcTc) -> [Located Name] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +ieLocNames :: IE pass -> [Located (IdP pass)] +#else +ieLocNames :: IE Name -> [Located Name] +#endif ieLocNames (IEVar n) = [unwrapName n] ieLocNames (IEThingAbs n) = [unwrapName n] ieLocNames (IEThingAll n) = [unwrapName n] @@ -932,7 +967,11 @@ collectDocs = go Nothing [] go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) finished decl docs rest = (decl, reverse docs) : rest ---ungroup :: HsGroup Name -> [LHsDecl Name] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] +#else +ungroup :: HsGroup Name -> [LHsDecl Name] +#endif ungroup group_ = #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ @@ -962,7 +1001,11 @@ mkDecls field con struct = [L loc (con decl) | L loc decl <- field struct] sortByLoc :: [Located a] -> [Located a] sortByLoc = L.sortBy (comparing getLoc) ---classDeclDocs :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])] +#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 where decls = docs ++ defs ++ sigs ++ ats @@ -971,13 +1014,21 @@ classDeclDocs class_ = collectDocs . sortByLoc $ decls sigs = mkDecls tcdSigs SigD class_ ats = mkDecls tcdATs (TyClD . FamDecl) class_ ---conDeclDocs :: ConDecl Name -> [(Name, [HsDocString], SrcSpan)] +#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 (\(L span n) -> (n, maybe [] ((: []) . unLoc) $ con_doc conDecl, span)) . getConNames $ conDecl ---selectorDocs :: ConDecl name -> [(PostRn name name, [HsDocString], SrcSpan)] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +selectorDocs :: ConDecl pass -> [(PostRn pass (IdP pass), [HsDocString], SrcSpan)] +#else +selectorDocs :: ConDecl name -> [(PostRn name name, [HsDocString], SrcSpan)] +#endif selectorDocs con = case getConDetails con of RecCon (L _ flds) -> @@ -990,15 +1041,13 @@ selectorDocs con = flds _ -> [] - #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) subordinateNamesWithDocs :: [GenLocated SrcSpan (HsDecl GhcRn)] -> [(Name, [HsDocString], SrcSpan)] -#endif -subordinateNamesWithDocs _ = -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) - [] #else - concatMap +subordinateNamesWithDocs :: [GenLocated SrcSpan (HsDecl Name)] -> [(Name, [HsDocString], SrcSpan)] +#endif +subordinateNamesWithDocs = + concatMap (\(L span tyClDecl) -> case tyClDecl of TyClD classDecl@ClassDecl {..} -> @@ -1009,16 +1058,24 @@ subordinateNamesWithDocs _ = concatMap (\(L _ con) -> conDeclDocs con ++ selectorDocs con) $ dd_cons tcdDataDefn InstD (DataFamInstD DataFamInstDecl {..}) -> +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + concatMap (conDeclDocs . unLoc) . dd_cons . feqn_rhs . hsib_body $ dfid_eqn +#else concatMap (conDeclDocs . unLoc) . dd_cons $ dfid_defn - _ -> []) #endif + _ -> []) + isUserLSig :: LSig name -> Bool isUserLSig (L _ TypeSig {}) = True isUserLSig (L _ ClassOpSig {}) = True isUserLSig _ = False ---getMainDeclBinder :: HsDecl name -> [name] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +getMainDeclBinder :: HsDecl pass -> [IdP pass] +#else +getMainDeclBinder :: HsDecl name -> [name] +#endif getMainDeclBinder (TyClD d) = [tcdName d] getMainDeclBinder (ValD d) = case collectHsBindBinders d of @@ -1029,7 +1086,11 @@ getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] getMainDeclBinder (ForD ForeignExport {}) = [] getMainDeclBinder _ = [] ---sigNameNoLoc :: Sig name -> [name] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +sigNameNoLoc :: Sig pass -> [IdP pass] +#else +sigNameNoLoc :: Sig name -> [name] +#endif sigNameNoLoc (TypeSig ns _) = map unLoc ns sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) @@ -1042,7 +1103,7 @@ sigNameNoLoc (InlineSig n _) = [unLoc n] sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns sigNameNoLoc _ = [] -clsInstDeclSrcSpan :: ClsInstDecl name -> SrcSpan +clsInstDeclSrcSpan :: ClsInstDecl a -> SrcSpan clsInstDeclSrcSpan ClsInstDecl {cid_poly_ty = ty} = getLoc (hsSigType ty) hsDocsToDocH :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Doc Name @@ -1120,6 +1181,9 @@ rename dflags gre = rn 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 -- | Wrap an identifier that's out of scope (i.e. wasn't found in -- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently diff --git a/src/HaskellCodeExplorer/ModuleInfo.hs b/src/HaskellCodeExplorer/ModuleInfo.hs index 5145fa5..ddd7e9f 100644 --- a/src/HaskellCodeExplorer/ModuleInfo.hs +++ b/src/HaskellCodeExplorer/ModuleInfo.hs @@ -6,6 +6,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StrictData #-} module HaskellCodeExplorer.ModuleInfo @@ -25,7 +26,9 @@ import qualified Data.IntervalMap.Strict as IVM import qualified Data.List as L hiding (span) import Data.Maybe (fromMaybe, mapMaybe) import Data.Ord (comparing) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) import HsExtension (GhcRn) +#endif import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -475,6 +478,8 @@ createDeclarations :: DynFlags #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -> HsGroup GhcRn +#else + -> HsGroup Name #endif -> TypeEnv -> S.Set Name diff --git a/src/HaskellCodeExplorer/Types.hs b/src/HaskellCodeExplorer/Types.hs index 9e3667d..f94b3af 100644 --- a/src/HaskellCodeExplorer/Types.hs +++ b/src/HaskellCodeExplorer/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -47,6 +48,11 @@ import Documentation.Haddock.Types , Header(..) , Hyperlink(..) , Picture(..) +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + , Table(..) + , TableCell(..) + , TableRow(..) +#endif ) import GHC.Generics (Generic) import Prelude hiding (id) @@ -781,7 +787,7 @@ docToHtml modToHtml idToHtml = toStrict . renderHtml . toH in htmlPrompt >> htmlExpression >> mapM_ (Html.span . Html.toHtml) (unlines results)) examples - toH (DocString str) = Html.span . Html.toHtml $ T.pack str + toH (DocString str) = Html.span . Html.toHtml $ T.pack str toH (DocHeader (Header level doc)) = toHeader level $ toH doc where toHeader 1 = Html.h1 @@ -790,6 +796,18 @@ docToHtml modToHtml idToHtml = toStrict . renderHtml . toH toHeader 4 = Html.h4 toHeader 5 = Html.h5 toHeader _ = Html.h6 +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) + toH (DocTable (Table hs bs)) = + let tableRowToH tdOrTh (TableRow cells) = + Html.tr $ mapM_ (tableCellToH tdOrTh) cells + tableCellToH tdOrTh (TableCell colspan rowspan doc) = + (tdOrTh $ toH doc) Html.!? + (colspan /= 1, (Attr.colspan (Html.stringValue $ show colspan))) Html.!? + (rowspan /= 1, (Attr.rowspan (Html.stringValue $ show rowspan))) + in Html.table $ + Html.thead (mapM_ (tableRowToH Html.th) hs) >> + Html.tbody (mapM_ (tableRowToH Html.td) bs) +#endif instance A.ToJSON HaskellModuleName where toJSON (HaskellModuleName name) = A.String name diff --git a/stack.yaml b/stack.yaml index 89f09bb..f086c39 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-12.4 +resolver: lts-12.12 packages: - '.' - location: vendor/cabal-helper-0.8.1.2 diff --git a/test/Main.hs b/test/Main.hs index f2247fb..11b94fb 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -140,17 +140,25 @@ moduleInfoSpec modInfo = it "returns valid map of identifiers " $ let removeLocationInfo :: HCE.LocationInfo -> HCE.LocationInfo removeLocationInfo _ = HCE.UnknownLocation "" - in U.transformBi - removeLocationInfo - (HCE.idInfoMap (modInfo :: HCE.ModuleInfo)) `shouldBe` - U.transformBi removeLocationInfo testIdInfoMap + removePackageVersionFromExternalId :: HCE.ExternalId -> HCE.ExternalId + removePackageVersionFromExternalId extId@(HCE.ExternalId textId) = case T.splitOn "|" textId of + packageId:rest -> case T.splitOn "-" packageId of + packageIdParts@(_:_) -> HCE.ExternalId $ T.intercalate "|" ((T.intercalate "-" (init packageIdParts)) : rest) + _ -> extId + _ -> extId + cleanup :: HCE.IdentifierInfoMap -> HCE.IdentifierInfoMap + cleanup = U.transformBi removeLocationInfo . U.transformBi removePackageVersionFromExternalId + in + cleanup (HCE.idInfoMap (modInfo :: HCE.ModuleInfo)) `shouldBe` cleanup testIdInfoMap #endif it "returns valid map of identifier occurrences" $ HCE.idOccMap (modInfo :: HCE.ModuleInfo) `shouldBe` testIdOccMap -stackYamlArg :: [String] -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) +stackYamlArg :: [String] +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) stackYamlArg = [] +#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) +stackYamlArg = ["--stack-yaml=stack-8.2.2.yaml" ] #else stackYamlArg = ["--stack-yaml=stack-8.0.2.yaml" ] #endif @@ -177,7 +185,7 @@ buildAndIndexTestPackage currentDir = do _ <- readProcess stackExecutable - (["build", "--test"] ++ stackYamlArg) + (["build", "--test","--force-dirty"] ++ stackYamlArg) "" runLoggingT (createPackageInfo @@ -1209,3 +1217,5 @@ testIdInfoMap = , isExported = False }) ] + + diff --git a/test/test-package/stack-8.2.2.yaml b/test/test-package/stack-8.2.2.yaml new file mode 100644 index 0000000..5bad591 --- /dev/null +++ b/test/test-package/stack-8.2.2.yaml @@ -0,0 +1 @@ +resolver: lts-11.3 diff --git a/test/test-package/stack.yaml b/test/test-package/stack.yaml index 5bad591..80a9a5a 100644 --- a/test/test-package/stack.yaml +++ b/test/test-package/stack.yaml @@ -1 +1 @@ -resolver: lts-11.3 +resolver: lts-12.12 -- cgit v1.2.3 From 2b5cbccffa21d9f80f804bd9d95d4527ce3246b7 Mon Sep 17 00:00:00 2001 From: alexwl Date: Sun, 14 Oct 2018 17:15:05 +0300 Subject: Index type constructor in RoleAnnotDecl --- src/HaskellCodeExplorer/AST/RenamedSource.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) (limited to 'src/HaskellCodeExplorer') diff --git a/src/HaskellCodeExplorer/AST/RenamedSource.hs b/src/HaskellCodeExplorer/AST/RenamedSource.hs index 592c8f7..46ecc8f 100644 --- a/src/HaskellCodeExplorer/AST/RenamedSource.hs +++ b/src/HaskellCodeExplorer/AST/RenamedSource.hs @@ -62,6 +62,7 @@ import GHC , TyFamEqn(..) #endif , Type + , RoleAnnotDecl(..) , unLoc ) #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) @@ -111,7 +112,8 @@ namesFromRenamedSource = hsRecFieldExprNames `extQ` hsRecAmbFieldExprNames `extQ` hsRecFieldPatNames `extQ` - foreignDeclNames) + foreignDeclNames `extQ` + roleAnnotationNames) #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) fieldOccName :: Bool -> FieldOcc GhcRn -> NameOccurrence @@ -599,3 +601,16 @@ foreignDeclNames decl = , isBinder = True } ] + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +roleAnnotationNames :: RoleAnnotDecl GhcRn -> [NameOccurrence] +#else +roleAnnotationNames :: RoleAnnotDecl Name -> [NameOccurrence] +#endif +roleAnnotationNames (RoleAnnotDecl n _) = + [ NameOccurrence + { locatedName = Just <$> n + , description = "RoleAnnotDecl" + , isBinder = False + } + ] -- cgit v1.2.3