From 069ae2042ed716211fba513b8243fb7950a19bbf Mon Sep 17 00:00:00 2001 From: Yuchen Pei Date: Wed, 8 Jun 2022 23:29:46 +1000 Subject: removed all CPP macros, and formatted code with brittany --- src/HaskellCodeExplorer/AST/RenamedSource.hs | 756 +++++------ src/HaskellCodeExplorer/AST/TypecheckedSource.hs | 1419 +++++++++----------- src/HaskellCodeExplorer/GhcUtils.hs | 1528 ++++++++++------------ src/HaskellCodeExplorer/ModuleInfo.hs | 1307 +++++++++--------- src/HaskellCodeExplorer/PackageInfo.hs | 1000 +++++++------- 5 files changed, 2874 insertions(+), 3136 deletions(-) diff --git a/src/HaskellCodeExplorer/AST/RenamedSource.hs b/src/HaskellCodeExplorer/AST/RenamedSource.hs index 49070c8..7f0301b 100644 --- a/src/HaskellCodeExplorer/AST/RenamedSource.hs +++ b/src/HaskellCodeExplorer/AST/RenamedSource.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} @@ -10,97 +9,78 @@ module HaskellCodeExplorer.AST.RenamedSource , namesFromRenamedSource ) where -import GHC.Types.Basic (TupleSort(..)) -import GHC.Data.BooleanFormula (BooleanFormula(..)) -import Data.Generics (Data, everything, extQ, mkQ) -import Data.Maybe (mapMaybe) -import qualified Data.Text as T (Text) -import GHC - ( AmbiguousFieldOcc(..) - , ConDecl(..) - , ConDeclField(..) -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -#else - , DataFamInstDecl(..) -#endif - , FamilyDecl(..) - , FieldOcc(..) - , FixitySig(..) - , ForeignDecl(..) - , FunDep(..) - , GenLocated(..) - , getLocA - , HsBindLR(..) - , HsExpr(..) -#if MIN_VERSION_GLASGOW_HASKELL(8,4,1,0) - , HsPatSynDetails -#else - , HsPatSynDetails(..) -#endif - , HsRecField'(..) - , HsTupleSort(..) - , HsTyLit(..) - , HsTyVarBndr(..) - , HsType(..) - , IE(..) - , LHsBindLR - , LHsExpr -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -#else - , LHsQTyVars(..) -#endif - , LHsType - , LPat - , LSig - , LTyClDecl - , Located - , HsBracket(..) -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) - , HsMatchContext(..) - , Match(..) -#else - , m_fixity - , MatchFixity(..) -#endif - , MatchGroup(..) - , Name - , Pat(..) - , PatSynBind(..) - , reLocN - , Sig(..) - , TyClDecl(..) -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) - , FamEqn(..) - , HsDataDefn(..) -#else - , TyFamEqn(..) -#endif - , Type - , RoleAnnotDecl(..) - , InjectivityAnn (..) - , unLoc - ) -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -import GHC.Hs.Extension (GhcRn) -#endif -import HaskellCodeExplorer.GhcUtils (hsPatSynDetails, ieLocNames) -import Prelude hiding (span) -import GHC.Builtin.Types - ( nilDataConName - , tupleTyConName - , naturalTy - , typeSymbolKind - ) -import GHC.Types.SrcLoc - ( mkRealSrcSpan - , mkRealSrcLoc - , realSrcSpanEnd - , realSrcSpanStart - , srcLocCol - , srcLocFile - , srcLocLine - , SrcSpan(..) - ) +import Data.Generics ( Data + , everything + , extQ + , mkQ + ) +import Data.Maybe ( mapMaybe ) +import qualified Data.Text as T + ( Text ) +import GHC ( AmbiguousFieldOcc(..) + , ConDecl(..) + , ConDeclField(..) + , FamEqn(..) + , FamilyDecl(..) + , FieldOcc(..) + , FixitySig(..) + , ForeignDecl(..) + , FunDep(..) + , GenLocated(..) + , HsBindLR(..) + , HsBracket(..) + , HsDataDefn(..) + , HsExpr(..) + , HsMatchContext(..) + , HsPatSynDetails + , HsRecField'(..) + , HsTupleSort(..) + , HsTyLit(..) + , HsTyVarBndr(..) + , HsType(..) + , IE(..) + , InjectivityAnn(..) + , LHsBindLR + , LHsExpr + , LHsType + , LPat + , LSig + , LTyClDecl + , Located + , Match(..) + , MatchGroup(..) + , Name + , Pat(..) + , PatSynBind(..) + , RoleAnnotDecl(..) + , Sig(..) + , TyClDecl(..) + , Type + , getLocA + , reLocN + , unLoc + ) +import GHC.Builtin.Types ( naturalTy + , nilDataConName + , tupleTyConName + , typeSymbolKind + ) +import GHC.Data.BooleanFormula ( BooleanFormula(..) ) +import GHC.Hs.Extension ( GhcRn ) +import GHC.Types.Basic ( TupleSort(..) ) +import GHC.Types.SrcLoc ( SrcSpan(..) + , mkRealSrcLoc + , mkRealSrcSpan + , realSrcSpanEnd + , realSrcSpanStart + , srcLocCol + , srcLocFile + , srcLocLine + ) +import HaskellCodeExplorer.GhcUtils ( hsPatSynDetails + , ieLocNames + ) +import Prelude hiding ( span ) data NameOccurrence = NameOccurrence { locatedName :: Located (Maybe Name) , description :: T.Text @@ -112,316 +92,284 @@ data NameOccurrence -- | Here we are only interested in a small subset of all AST nodes, so it is -- convenient to use generic functions namesFromRenamedSource :: (Data a) => a -> [NameOccurrence] -namesFromRenamedSource = - everything - (++) - ([] - `mkQ` hsExprNames - `extQ` matchGroupNames - `extQ` bindNames - `extQ` patNames - `extQ` sigNames - `extQ` hsTypeNames - `extQ` tyClDeclNames - `extQ` familyDeclNames - `extQ` familyEqNames - `extQ` dataEqNames - `extQ` conDeclNames - `extQ` importNames - `extQ` hsTyVarBndrNames - `extQ` hsPatSynDetailsNames - `extQ` conDeclFieldNames - `extQ` hsRecFieldExprNames - `extQ` hsRecAmbFieldExprNames - `extQ` hsRecFieldPatNames - `extQ` foreignDeclNames - `extQ` roleAnnotationNames - `extQ` injectivityAnnotationNames - ) +namesFromRenamedSource = everything + (++) + ( [] + `mkQ` hsExprNames + `extQ` matchGroupNames + `extQ` bindNames + `extQ` patNames + `extQ` sigNames + `extQ` hsTypeNames + `extQ` tyClDeclNames + `extQ` familyDeclNames + `extQ` familyEqNames + `extQ` dataEqNames + `extQ` conDeclNames + `extQ` importNames + `extQ` hsTyVarBndrNames + `extQ` hsPatSynDetailsNames + `extQ` conDeclFieldNames + `extQ` hsRecFieldExprNames + `extQ` hsRecAmbFieldExprNames + `extQ` hsRecFieldPatNames + `extQ` foreignDeclNames + `extQ` roleAnnotationNames + `extQ` injectivityAnnotationNames + ) fieldOccName :: Bool -> FieldOcc GhcRn -> NameOccurrence -fieldOccName isBinder (FieldOcc name located) = - NameOccurrence - { locatedName = L (getLocA located) (Just name) - , description = "FieldOcc" - , isBinder = isBinder - } +fieldOccName isBinder (FieldOcc name located) = NameOccurrence + { locatedName = L (getLocA located) (Just name) + , description = "FieldOcc" + , isBinder = isBinder + } conDeclFieldNames :: ConDeclField GhcRn -> [NameOccurrence] conDeclFieldNames ConDeclField {..} = map (fieldOccName True . unLoc) cd_fld_names -hsRecFieldExprNames :: HsRecField' (FieldOcc GhcRn) (LHsExpr GhcRn) -> [NameOccurrence] -hsRecFieldExprNames HsRecField {..} = [fieldOccName False $ unLoc hsRecFieldLbl] +hsRecFieldExprNames + :: HsRecField' (FieldOcc GhcRn) (LHsExpr GhcRn) -> [NameOccurrence] +hsRecFieldExprNames HsRecField {..} = + [fieldOccName False $ unLoc hsRecFieldLbl] -hsRecAmbFieldExprNames :: HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn) -> [NameOccurrence] +hsRecAmbFieldExprNames + :: HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn) -> [NameOccurrence] hsRecAmbFieldExprNames HsRecField {..} = let (L span recField) = hsRecFieldLbl - mbName = - case recField of - Ambiguous _ _ -> Nothing - Unambiguous name _ -> Just name - in [ NameOccurrence - { locatedName = L span mbName - , description = "AmbiguousFieldOcc" - , isBinder = False - } + mbName = case recField of + Ambiguous _ _ -> Nothing + Unambiguous name _ -> Just name + in [ NameOccurrence { locatedName = L span mbName + , description = "AmbiguousFieldOcc" + , isBinder = False + } ] -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -hsRecFieldPatNames :: HsRecField' (FieldOcc GhcRn) (LPat GhcRn) -> [NameOccurrence] -#else -hsRecFieldPatNames :: HsRecField' (FieldOcc Name) (LPat Name) -> [NameOccurrence] -#endif +hsRecFieldPatNames + :: HsRecField' (FieldOcc GhcRn) (LPat GhcRn) -> [NameOccurrence] hsRecFieldPatNames HsRecField {..} = [fieldOccName False $ unLoc hsRecFieldLbl] hsExprNames :: LHsExpr GhcRn -> [NameOccurrence] hsExprNames (L _span (HsVar _ name)) = - [ NameOccurrence - { locatedName = Just <$> reLocN name - , description = "HsVar" - , isBinder = False - } + [ NameOccurrence { locatedName = Just <$> reLocN name + , description = "HsVar" + , isBinder = False + } ] hsExprNames lhe@(L _ (ExplicitList _ exprs)) - | null exprs = - [ NameOccurrence - { locatedName = L (getLocA lhe) $ Just nilDataConName - , description = "ExplicitList" - , isBinder = False - } + | null exprs + = [ NameOccurrence { locatedName = L (getLocA lhe) $ Just nilDataConName + , description = "ExplicitList" + , isBinder = False + } ] - | otherwise = [] + | otherwise + = [] hsExprNames (L _span (RecordCon _ name _)) = - [ NameOccurrence - { locatedName = Just <$> reLocN name - , description = "RecordCon" - , isBinder = False - } + [ NameOccurrence { locatedName = Just <$> reLocN name + , description = "RecordCon" + , isBinder = False + } ] hsExprNames (L _span (HsRecFld _ (Unambiguous name located))) = - [ NameOccurrence - { locatedName = L (getLocA located) (Just name) - , description = "HsRecFld" - , isBinder = False - } + [ NameOccurrence { locatedName = L (getLocA located) (Just name) + , description = "HsRecFld" + , isBinder = False + } ] hsExprNames (L _span (HsRecFld _ (Ambiguous _name located))) = - [ NameOccurrence - { locatedName = L (getLocA located) Nothing - , description = "HsRecFld" - , isBinder = False - } + [ NameOccurrence { locatedName = L (getLocA located) Nothing + , description = "HsRecFld" + , isBinder = False + } ] hsExprNames lhr@(L _ (HsRnBracketOut _ (VarBr _ quote name) _)) = case getLocA lhr of RealSrcSpan realSpan _ -> - let start = realSrcSpanStart realSpan - end = realSrcSpanEnd realSpan - offset = - if quote - then 1 -- 'x - else 2 -- ''T - start' = - mkRealSrcLoc - (srcLocFile start) - (srcLocLine start) - (srcLocCol start + offset) - span' = RealSrcSpan (mkRealSrcSpan start' end) Nothing - in [ NameOccurrence - { locatedName = L span' (Just $ unLoc name) - , description = "VarBr" - , isBinder = False - } - ] + let + start = realSrcSpanStart realSpan + end = realSrcSpanEnd realSpan + offset = if quote + then 1 -- 'x + else 2 -- ''T + start' = mkRealSrcLoc (srcLocFile start) + (srcLocLine start) + (srcLocCol start + offset) + span' = RealSrcSpan (mkRealSrcSpan start' end) Nothing + in + [ NameOccurrence { locatedName = L span' (Just $ unLoc name) + , description = "VarBr" + , isBinder = False + } + ] _ -> [] hsExprNames _ = [] matchGroupNames :: MatchGroup GhcRn (LHsExpr GhcRn) -> [NameOccurrence] matchGroupNames = - mapMaybe (fmap toNameOcc . matchContextName . m_ctxt . unLoc) . - unLoc . mg_alts - where + mapMaybe (fmap toNameOcc . matchContextName . m_ctxt . unLoc) + . unLoc + . mg_alts + where --matchContextName :: HsMatchContext Name -> Maybe (Located Name) - matchContextName (FunRhs name _ _bool) = Just name - matchContextName _ = Nothing - --toNameOcc :: LIdP GhcRn -> NameOccurrence - toNameOcc n = - NameOccurrence - {locatedName = Just <$> reLocN n, description = "Match", isBinder = True} + matchContextName (FunRhs name _ _bool) = Just name + matchContextName _ = Nothing + --toNameOcc :: LIdP GhcRn -> NameOccurrence + toNameOcc n = NameOccurrence { locatedName = Just <$> reLocN n + , description = "Match" + , isBinder = True + } bindNames :: LHsBindLR GhcRn GhcRn -> [NameOccurrence] bindNames (L _span (PatSynBind _ PSB {..})) = - [ NameOccurrence - { locatedName = Just <$> reLocN psb_id - , description = "PatSynBind" - , isBinder = True - } + [ NameOccurrence { locatedName = Just <$> reLocN psb_id + , description = "PatSynBind" + , isBinder = True + } ] bindNames _ = [] hsPatSynDetailsNames :: HsPatSynDetails GhcRn -> [NameOccurrence] hsPatSynDetailsNames = map - (\name -> - NameOccurrence - { locatedName = Just <$> name - , description = "HsPatSynDetails" - , isBinder = True - }) . - hsPatSynDetails + (\name -> NameOccurrence { locatedName = Just <$> name + , description = "HsPatSynDetails" + , isBinder = True + } + ) + . hsPatSynDetails -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) importNames :: IE GhcRn -> [NameOccurrence] -#else -importNames :: IE Name -> [NameOccurrence] -#endif importNames = map - (\name -> - NameOccurrence - { locatedName = Just <$> name - , description = "IE" - , isBinder = False - }) . - ieLocNames + (\name -> NameOccurrence { locatedName = Just <$> name + , description = "IE" + , isBinder = False + } + ) + . ieLocNames patNames :: LPat GhcRn -> [NameOccurrence] patNames (L _span (VarPat _ name)) = - [ NameOccurrence - { locatedName = Just <$> reLocN name - , description = "VarPat" - , isBinder = True - } + [ NameOccurrence { locatedName = Just <$> reLocN name + , description = "VarPat" + , isBinder = True + } ] patNames (L _span (ConPat _ name _)) = - [ NameOccurrence - { locatedName = Just <$> reLocN name - , description = "ConPatIn" - , isBinder = False - } + [ NameOccurrence { locatedName = Just <$> reLocN name + , description = "ConPatIn" + , isBinder = False + } ] patNames (L _span (AsPat _ name _)) = - [ NameOccurrence - { locatedName = Just <$> reLocN name - , description = "AsPat" - , isBinder = True - } + [ NameOccurrence { locatedName = Just <$> reLocN name + , description = "AsPat" + , isBinder = True + } ] patNames (L _span (NPlusKPat _ name _ _ _ _)) = - [ NameOccurrence - { locatedName = Just <$> reLocN name - , description = "NPlusKPat" - , isBinder = True - } + [ NameOccurrence { locatedName = Just <$> reLocN name + , description = "NPlusKPat" + , isBinder = True + } ] patNames _ = [] sigNames :: LSig GhcRn -> [NameOccurrence] -sigNames (L _span (TypeSig _ names _)) = - map - (\n -> - NameOccurrence - { locatedName = Just <$> reLocN n - , description = "TypeSig" - , isBinder = False - }) - names +sigNames (L _span (TypeSig _ names _)) = map + (\n -> NameOccurrence { locatedName = Just <$> reLocN n + , description = "TypeSig" + , isBinder = False + } + ) + names sigNames (L _span (PatSynSig _ names _)) = map (\name -> NameOccurrence (Just <$> reLocN name) "PatSynSig" False) names -sigNames (L _span (ClassOpSig _ _ names _)) = - map - (\n -> - NameOccurrence - { locatedName = Just <$> reLocN n - , description = "ClassOpSig" - , isBinder = True - }) - names -sigNames (L _span (FixSig _ (FixitySig _ names _))) = - map - (\n -> - NameOccurrence - { locatedName = Just <$> reLocN n - , description = "FixitySig" - , isBinder = False - }) - names +sigNames (L _span (ClassOpSig _ _ names _)) = map + (\n -> NameOccurrence { locatedName = Just <$> reLocN n + , description = "ClassOpSig" + , isBinder = True + } + ) + names +sigNames (L _span (FixSig _ (FixitySig _ names _))) = map + (\n -> NameOccurrence { locatedName = Just <$> reLocN n + , description = "FixitySig" + , isBinder = False + } + ) + names sigNames (L _span (InlineSig _ name _)) = - [ NameOccurrence - { locatedName = Just <$> reLocN name - , description = "InlineSig" - , isBinder = False - } + [ NameOccurrence { locatedName = Just <$> reLocN name + , description = "InlineSig" + , isBinder = False + } ] sigNames (L _span (SpecSig _ name _ _)) = - [ NameOccurrence - { locatedName = Just <$> reLocN name - , description = "SpecSig" - , isBinder = False - } + [ NameOccurrence { locatedName = Just <$> reLocN name + , description = "SpecSig" + , isBinder = False + } ] sigNames (L _span (MinimalSig _ _ (L _ boolFormula))) = map - (\n -> - NameOccurrence - { locatedName = Just <$> reLocN n - , description = "MinimalSig" - , isBinder = False - }) . - boolFormulaNames $ - boolFormula - where - boolFormulaNames :: BooleanFormula name -> [name] - boolFormulaNames (Var a) = [a] - boolFormulaNames (And fs) = concatMap (boolFormulaNames . unLoc) fs - boolFormulaNames (Or fs) = concatMap (boolFormulaNames . unLoc) fs - boolFormulaNames (Parens (L _ f)) = boolFormulaNames f + (\n -> NameOccurrence { locatedName = Just <$> reLocN n + , description = "MinimalSig" + , isBinder = False + } + ) + . boolFormulaNames + $ boolFormula + where + boolFormulaNames :: BooleanFormula name -> [name] + boolFormulaNames (Var a ) = [a] + boolFormulaNames (And fs ) = concatMap (boolFormulaNames . unLoc) fs + boolFormulaNames (Or fs ) = concatMap (boolFormulaNames . unLoc) fs + boolFormulaNames (Parens (L _ f)) = boolFormulaNames f sigNames (L _ _) = [] hsTypeNames :: LHsType GhcRn -> [NameOccurrence] hsTypeNames (L _span (HsTyVar _ _promoted name)) = - [ NameOccurrence - { locatedName = Just <$> reLocN name - , description = "HsTyVar" - , isBinder = False - } + [ NameOccurrence { locatedName = Just <$> reLocN name + , description = "HsTyVar" + , isBinder = False + } ] hsTypeNames lht@(L _ (HsTyLit _ lit)) = - let kind = - case lit of - HsNumTy _ _ -> naturalTy - HsStrTy _ _ -> typeSymbolKind - HsCharTy _ _ -> typeSymbolKind - in [ TyLitOccurrence - { locatedName = L (getLocA lht) Nothing - , description = "HsTyLit" - , kind = kind - } - ] + let kind = case lit of + HsNumTy _ _ -> naturalTy + HsStrTy _ _ -> typeSymbolKind + HsCharTy _ _ -> typeSymbolKind + in [ TyLitOccurrence { locatedName = L (getLocA lht) Nothing + , description = "HsTyLit" + , kind = kind + } + ] hsTypeNames (L _span (HsOpTy _ _ name _)) = - [ NameOccurrence - { locatedName = Just <$> reLocN name - , description = "HsOpTy" - , isBinder = False - } + [ NameOccurrence { locatedName = Just <$> reLocN name + , description = "HsOpTy" + , isBinder = False + } ] hsTypeNames lht@(L _ (HsTupleTy _ tupleSort types)) - | null types = - let sort = - case tupleSort of - HsUnboxedTuple -> UnboxedTuple - HsBoxedOrConstraintTuple -> BoxedTuple - in [ NameOccurrence - { locatedName = L (getLocA lht) (Just $ tupleTyConName sort 0) - , description = "HsTupleTy" - , isBinder = False - } - ] - | otherwise = [] + | null types + = let sort = case tupleSort of + HsUnboxedTuple -> UnboxedTuple + HsBoxedOrConstraintTuple -> BoxedTuple + in [ NameOccurrence + { locatedName = L (getLocA lht) (Just $ tupleTyConName sort 0) + , description = "HsTupleTy" + , isBinder = False + } + ] + | otherwise + = [] --https://ghc.haskell.org/trac/ghc/ticket/13737 --hsTypeNames (L span (HsExplicitListTy _kind types)) = ... --hsTypeNames (L span (HsExplicitTupleTy _kind types)) = ... @@ -433,136 +381,110 @@ hsTypeNames _ = [] -- this function for invisible cases hsTyVarBndrNames :: HsTyVarBndr () GhcRn -> [NameOccurrence] hsTyVarBndrNames (UserTyVar _ _ n) = - [ NameOccurrence - { locatedName = Just <$> reLocN n - , description = "UserTyVar" - , isBinder = True - } + [ NameOccurrence { locatedName = Just <$> reLocN n + , description = "UserTyVar" + , isBinder = True + } ] hsTyVarBndrNames (KindedTyVar _ _ n _) = - [ NameOccurrence - { locatedName = Just <$> reLocN n - , description = "KindedTyVar" - , isBinder = True - } + [ NameOccurrence { locatedName = Just <$> reLocN n + , description = "KindedTyVar" + , isBinder = True + } ] -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) tyClDeclNames :: LTyClDecl GhcRn -> [NameOccurrence] -#else -tyClDeclNames :: LTyClDecl Name -> [NameOccurrence] -#endif tyClDeclNames (L _span DataDecl {..}) = - [ NameOccurrence - { locatedName = Just <$> reLocN tcdLName - , description = "DataDecl" - , isBinder = True - } + [ NameOccurrence { locatedName = Just <$> reLocN tcdLName + , description = "DataDecl" + , isBinder = True + } ] tyClDeclNames (L _span SynDecl {..}) = - [ NameOccurrence - { locatedName = Just <$> reLocN tcdLName - , description = "SynDecl" - , isBinder = True - } + [ NameOccurrence { locatedName = Just <$> reLocN tcdLName + , description = "SynDecl" + , isBinder = True + } ] tyClDeclNames (L _span ClassDecl {..}) = - NameOccurrence - { locatedName = Just <$> reLocN tcdLName - , description = "ClassDecl" - , isBinder = True - } : - concatMap (go . unLoc) tcdFDs - where + NameOccurrence { locatedName = Just <$> reLocN tcdLName + , description = "ClassDecl" + , isBinder = True + } + : concatMap (go . unLoc) tcdFDs + where -- toNameOcc :: Located Name -> NameOccurrence - toNameOcc n = - NameOccurrence - { locatedName = Just <$> reLocN n - , description = "FunDep" - , isBinder = False - } - go (FunDep _ names1 names2) = map toNameOcc names1 ++ map toNameOcc names2 - go _ = [] + toNameOcc n = NameOccurrence { locatedName = Just <$> reLocN n + , description = "FunDep" + , isBinder = False + } + go (FunDep _ names1 names2) = map toNameOcc names1 ++ map toNameOcc names2 + go _ = [] tyClDeclNames _ = [] familyDeclNames :: FamilyDecl GhcRn -> [NameOccurrence] familyDeclNames FamilyDecl {..} = - [ NameOccurrence - { locatedName = Just <$> reLocN fdLName - , description = "FamilyDecl" - , isBinder = True - } + [ NameOccurrence { locatedName = Just <$> reLocN fdLName + , description = "FamilyDecl" + , isBinder = True + } ] familyEqNames :: FamEqn GhcRn (LHsType GhcRn) -> [NameOccurrence] -familyEqNames FamEqn {feqn_tycon = tyCon} = - [ NameOccurrence - { locatedName = Just <$> reLocN tyCon - , description = "FamEqn" - , isBinder = False - } +familyEqNames FamEqn { feqn_tycon = tyCon } = + [ NameOccurrence { locatedName = Just <$> reLocN tyCon + , description = "FamEqn" + , isBinder = False + } ] dataEqNames :: FamEqn GhcRn (HsDataDefn GhcRn) -> [NameOccurrence] -dataEqNames FamEqn {feqn_tycon = tyCon} = - [ NameOccurrence - { locatedName = Just <$> reLocN tyCon - , description = "FamEqn" - , isBinder = False - } +dataEqNames FamEqn { feqn_tycon = tyCon } = + [ NameOccurrence { locatedName = Just <$> reLocN tyCon + , description = "FamEqn" + , isBinder = False + } ] conDeclNames :: ConDecl GhcRn -> [NameOccurrence] -conDeclNames con = - case con of - ConDeclGADT {con_names = names} -> - map - (\n -> - NameOccurrence - { locatedName = Just <$> reLocN n - , description = "ConDeclGADT" - , isBinder = True - }) - names - ConDeclH98 {con_name = name} -> - [ NameOccurrence - { locatedName = Just <$> reLocN name - , description = "ConDeclH98" - , isBinder = True - } - ] +conDeclNames con = case con of + ConDeclGADT { con_names = names } -> map + (\n -> NameOccurrence { locatedName = Just <$> reLocN n + , description = "ConDeclGADT" + , isBinder = True + } + ) + names + ConDeclH98 { con_name = name } -> + [ NameOccurrence { locatedName = Just <$> reLocN name + , description = "ConDeclH98" + , isBinder = True + } + ] -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foreignDeclNames :: ForeignDecl GhcRn -> [NameOccurrence] -#else -foreignDeclNames :: ForeignDecl Name -> [NameOccurrence] -#endif foreignDeclNames decl = - [ NameOccurrence - { locatedName = Just <$> reLocN (fd_name decl) - , description = "ForeignDecl" - , isBinder = True - } + [ NameOccurrence { locatedName = Just <$> reLocN (fd_name decl) + , description = "ForeignDecl" + , isBinder = True + } ] roleAnnotationNames :: RoleAnnotDecl GhcRn -> [NameOccurrence] roleAnnotationNames (RoleAnnotDecl _ n _) = - [ NameOccurrence - { locatedName = Just <$> reLocN n - , description = "RoleAnnotDecl" - , isBinder = False - } + [ NameOccurrence { locatedName = Just <$> reLocN n + , description = "RoleAnnotDecl" + , isBinder = False + } ] injectivityAnnotationNames :: InjectivityAnn GhcRn -> [NameOccurrence] injectivityAnnotationNames (InjectivityAnn _ lhsName rhsNames) = injAnnNameOcc lhsName : map injAnnNameOcc rhsNames - where + where -- injAnnNameOcc :: GenLocated SrcSpan Name -> NameOccurrence - injAnnNameOcc n = - NameOccurrence - { locatedName = Just <$> reLocN n - , description = "InjectivityAnn" - , isBinder = False - } + injAnnNameOcc n = NameOccurrence { locatedName = Just <$> reLocN n + , description = "InjectivityAnn" + , isBinder = False + } diff --git a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs index d31634c..22911df 100644 --- a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs +++ b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -19,142 +18,157 @@ module HaskellCodeExplorer.AST.TypecheckedSource , removeOverlappingInterval ) where -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) -import qualified Data.HashMap.Strict as HM -import qualified Data.IntMap.Strict as IM -import qualified Data.IntervalMap.Strict as IVM -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe, mapMaybe) -import qualified Data.Set as S -import qualified Data.Text as T -import GHC.Core.Multiplicity (scaledThing) -import GHC - ( DynFlags - , TyThing(..) - , getLocA - , reLocA - , reLocN - , SrcLoc(..) - , srcSpanStart - , srcSpanEnd - ) -import GHC.Data.FastString - ( mkFastString - , FastString - , unpackFS - ) -import GHC.Unit.State (UnitState) -import GHC.Utils.Misc (thenCmp) -import HaskellCodeExplorer.GhcUtils -import qualified HaskellCodeExplorer.Types as HCE -import GHC.Hs.Binds (RecordPatSynField(..) -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -#else - , HsPatSynDetails (..) -#endif - ) -import GHC.Hs - ( ABExport(..) - , ApplicativeArg(..) - , ArithSeqInfo(..) - , FieldOcc(..) - , GRHS(..) - , GRHSs(..) - , HsBindLR(..) - , HsCmd(..) - , HsCmdTop(..) - , HsConDetails(..) - , HsExpr(..) - , HsLocalBindsLR(..) - , HsOverLit(..) - , HsPragE(..) - , HsRecField'(..) - , HsRecFields(..) - , HsTupArg(..) - , HsValBindsLR(..) - , HsValBindsLR(..) - , LGRHS - , LHsBindLR - , LHsBinds - , LHsCmd - , LHsCmd - , LHsCmdTop - , LHsExpr - , LHsRecField - , LHsRecUpdField - , LMatch - , LPat - , LStmtLR - , Match(..) - , Match(..) - , MatchGroup(..) - , ParStmtBlock(..) - , Pat(..) - , PatSynBind(..) - , StmtLR(..) - , selectorAmbiguousFieldOcc - , RecordUpdTc (..) - , ListPatTc (..) - , OverLitTc (..) - , MatchGroupTc (..) - , NHsValBindsLR (..) - ) -import GHC.Types.TypeEnv (TypeEnv, lookupTypeEnv) -import GHC.Hs.Extension (GhcTc) -import GHC.Types.Id (idType) -import GHC.Types.Id.Info (IdDetails(..)) -import GHC.Core.InstEnv - ( ClsInst(..) - , InstEnvs - , instanceSig - , is_dfun - , lookupUniqueInstEnv - ) -import GHC.Types.Name (Name, nameOccName, nameUnique) -import Prelude hiding (span) -import GHC.Types.SrcLoc - ( GenLocated(..) - , SrcSpan(..) - , isGoodSrcSpan - , UnhelpfulSpanReason(..) - , isOneLineSpan - , unLoc - ) -import GHC.Tc.Types.Evidence (HsWrapper(..)) -import GHC.Tc.Utils.Zonk (conLikeResTy, hsLitType) -import GHC.Core.Predicate (getClassPredTys_maybe) -import GHC.Core.Type - ( Type - , nonDetCmpTypes - , eqTypes - , eqType - , mkVisFunTys - , mkVisFunTyMany - , mkVisFunTysMany - , splitForAllTyCoVars - , splitFunTy_maybe - , splitFunTys - , substTys - , tidyOpenType - , zipTvSubst - ) -import GHC.Builtin.Types (mkListTy, mkTupleTy) -import GHC.Types.Unique (getKey) -import GHC.Types.Var (Id, Var, idDetails, isId, setVarName, setVarType, varName, varType) -import GHC.Types.Var.Env (TidyEnv) +import Control.Monad ( unless + , void + , when + ) +import Control.Monad.State.Strict ( State + , get + , modify' + ) +import Data.Either ( fromLeft + , isLeft + ) +import qualified Data.HashMap.Strict as HM +import qualified Data.IntMap.Strict as IM +import qualified Data.IntervalMap.Strict as IVM +import qualified Data.Map.Strict as M +import Data.Maybe ( fromMaybe + , mapMaybe + ) +import qualified Data.Set as S +import qualified Data.Text as T +import GHC ( DynFlags + , SrcLoc(..) + , TyThing(..) + , getLocA + , reLocA + , reLocN + , srcSpanEnd + , srcSpanStart + ) +import GHC.Builtin.Types ( mkListTy + , mkTupleTy + ) +import GHC.Core.Class ( Class + , classTyVars + ) +import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Core.DataCon ( dataConRepType ) +import GHC.Core.InstEnv ( ClsInst(..) + , InstEnvs + , instanceSig + , is_dfun + , lookupUniqueInstEnv + ) +import GHC.Core.Multiplicity ( scaledThing ) +import GHC.Core.PatSyn ( patSynBuilder ) +import GHC.Core.Predicate ( getClassPredTys_maybe ) +import GHC.Core.Type ( Type + , eqType + , eqTypes + , mkVisFunTyMany + , mkVisFunTys + , mkVisFunTysMany + , nonDetCmpTypes + , splitForAllTyCoVars + , splitFunTy_maybe + , splitFunTys + , substTys + , tidyOpenType + , zipTvSubst + ) +import GHC.Data.Bag ( bagToList ) +import GHC.Data.FastString ( FastString + , mkFastString + , unpackFS + ) +import GHC.Hs ( ABExport(..) + , ApplicativeArg(..) + , ArithSeqInfo(..) + , FieldOcc(..) + , GRHS(..) + , GRHSs(..) + , HsBindLR(..) + , HsCmd(..) + , HsCmdTop(..) + , HsConDetails(..) + , HsExpr(..) + , HsLocalBindsLR(..) + , HsOverLit(..) + , HsPragE(..) + , HsRecField'(..) + , HsRecFields(..) + , HsTupArg(..) + , HsValBindsLR(..) + , LGRHS + , LHsBindLR + , LHsBinds + , LHsCmd + , LHsCmdTop + , LHsExpr + , LHsRecField + , LHsRecUpdField + , LMatch + , LPat + , LStmtLR + , ListPatTc(..) + , Match(..) + , MatchGroup(..) + , MatchGroupTc(..) + , NHsValBindsLR(..) + , OverLitTc(..) + , ParStmtBlock(..) + , Pat(..) + , PatSynBind(..) + , RecordUpdTc(..) + , StmtLR(..) + , selectorAmbiguousFieldOcc + ) +import GHC.Hs.Binds ( RecordPatSynField(..) ) +import GHC.Hs.Extension ( GhcTc ) +import GHC.Tc.Types.Evidence ( HsWrapper(..) ) +import GHC.Tc.Utils.Zonk ( conLikeResTy + , hsLitType + ) +import GHC.Types.Basic ( Origin(..) ) +import GHC.Types.Id ( idType ) +import GHC.Types.Id.Info ( IdDetails(..) ) +import GHC.Types.Name ( Name + , nameOccName + , nameUnique + ) +import GHC.Types.SrcLoc ( GenLocated(..) + , SrcSpan(..) + , UnhelpfulSpanReason(..) + , isGoodSrcSpan + , isOneLineSpan + , unLoc + ) +import GHC.Types.TypeEnv ( TypeEnv + , lookupTypeEnv + ) +import GHC.Types.Unique ( getKey ) +import GHC.Types.Var ( Id + , Var + , idDetails + , isId + , setVarName + , setVarType + , varName + , varType + ) +import GHC.Types.Var.Env ( TidyEnv ) +import GHC.Unit.State ( UnitState ) +import GHC.Utils.Misc ( thenCmp ) +import HaskellCodeExplorer.GhcUtils +import qualified HaskellCodeExplorer.Types as HCE +import Prelude hiding ( span ) data ASTState = ASTState - { astStateExprInfoMap :: !HCE.ExpressionInfoMap + { astStateExprInfoMap :: !HCE.ExpressionInfoMap -- ^ Type of each expression - , astStateIdOccMap :: !HCE.IdentifierOccurrenceMap + , astStateIdOccMap :: !HCE.IdentifierOccurrenceMap -- ^ Each occurrence of an identifier in a source code , astStateIdSrcSpanMap :: !(M.Map SrcSpan (Var, Maybe (Type, [Type]))) -- ^ Intermediate data structure that is used to populate 'IdentifierOccurrenceMap' @@ -162,38 +176,42 @@ data ASTState = ASTState -- 'SrcSpan' - location of an identifier in a source code -- 'Type' - 'expected' type of an identifier -- '[Type]' - types at which type variables are instantiated - , astStateTidyEnv :: !TidyEnv + , astStateTidyEnv :: !TidyEnv -- ^ 'TidyEnv' is used to prevent name clashes of free type variables. -- ('TidyEnv' contains all free type variables in scope) - , astStateHsWrapper :: !(Maybe HsWrapper) + , astStateHsWrapper :: !(Maybe HsWrapper) -- ^ HsWrapper comes from 'HsWrap' constructor of 'HsExpr' datatype. - , astStateEnv :: !Environment + , astStateEnv :: !Environment -- ^ 'Environment' doesn't change - , astStateTypeErrors :: [TypeError] + , astStateTypeErrors :: [TypeError] -- ^ Non-empty list of TypeError's indicates that most likely there is a bug in -- a fold_something function in this module. } -- | A 'TypeError' means that an assumption about a type of an AST node is incorrect. data TypeError = TypeError - { typeErrorSrcSpan :: SrcSpan - , typeErrorMessage :: T.Text + { typeErrorSrcSpan :: SrcSpan + , typeErrorMessage :: T.Text , typeErrorASTNodeName :: T.Text - } deriving (Show, Eq) + } + deriving (Show, Eq) data Environment = Environment - { envDynFlags :: DynFlags - , envUnitState :: UnitState - , envTypeEnv :: TypeEnv - , envInstEnv :: InstEnvs - , envTransformation :: HCE.SourceCodeTransformation - , envPackageId :: HCE.PackageId + { envDynFlags :: DynFlags + , envUnitState :: UnitState + , envTypeEnv :: TypeEnv + , envInstEnv :: InstEnvs + , envTransformation :: HCE.SourceCodeTransformation + , envPackageId :: HCE.PackageId , envCurrentModuleDefSites :: HCE.DefinitionSiteMap , envFileMap :: HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath , envDefSiteMap :: HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap - , envModuleNameMap :: HM.HashMap HCE.HaskellModuleName (HM.HashMap HCE.ComponentId HCE.HaskellModulePath) + , envModuleNameMap + :: HM.HashMap + HCE.HaskellModuleName + (HM.HashMap HCE.ComponentId HCE.HaskellModulePath) , envExportedNames :: S.Set Name - , envComponentId :: HCE.ComponentId + , envComponentId :: HCE.ComponentId } -- | Indicates whether an expression consists of more than one token. @@ -205,55 +223,49 @@ data ExprSort deriving (Show, Eq) exprSort :: HsExpr a -> ExprSort -exprSort HsVar {} = Simple -exprSort HsIPVar {} = Simple -exprSort HsOverLit {} = Simple -exprSort HsLit {} = Simple +exprSort HsVar{} = Simple +exprSort HsIPVar{} = Simple +exprSort HsOverLit{} = Simple +exprSort HsLit{} = Simple -exprSort (ExplicitTuple _ args _) - | null args = Simple - | otherwise = Composite -exprSort (ExplicitList _ args) - | null args = Simple - | otherwise = Composite +exprSort (ExplicitTuple _ args _) | null args = Simple + | otherwise = Composite +exprSort (ExplicitList _ args) | null args = Simple + | otherwise = Composite exprSort _ = Composite patSort :: Pat a -> ExprSort -patSort WildPat {} = Simple -patSort LitPat {} = Simple -patSort NPat {} = Simple -patSort (ListPat _ pats) - | null pats = Simple - | otherwise = Composite -patSort (TuplePat _ pats _) - | null pats = Simple - | otherwise = Composite +patSort WildPat{} = Simple +patSort LitPat{} = Simple +patSort NPat{} = Simple +patSort (ListPat _ pats) | null pats = Simple + | otherwise = Composite +patSort (TuplePat _ pats _) | null pats = Simple + | otherwise = Composite patSort _ = Composite -- | Splits a type of a function, adds 'TypeError' to 'ASTState' -- in case of failure. -splitFunTySafe :: - SrcSpan -> T.Text -> Type -> State ASTState (Maybe (Type, Type)) -splitFunTySafe srcSpan astNode typ = - case splitFunTy_maybe typ of - Just (_, ty1, ty2) -> return $ Just (ty1, ty2) - Nothing -> do - flags <- envDynFlags . astStateEnv <$> get - let typeError = - TypeError - { typeErrorSrcSpan = srcSpan - , typeErrorMessage = T.append "splitFunTy : " $ toText flags typ - , typeErrorASTNodeName = astNode - } - modify' - (\st -> st {astStateTypeErrors = typeError : astStateTypeErrors st}) - return Nothing +splitFunTySafe + :: SrcSpan -> T.Text -> Type -> State ASTState (Maybe (Type, Type)) +splitFunTySafe srcSpan astNode typ = case splitFunTy_maybe typ of + Just (_, ty1, ty2) -> return $ Just (ty1, ty2) + Nothing -> do + flags <- envDynFlags . astStateEnv <$> get + let typeError = TypeError + { typeErrorSrcSpan = srcSpan + , typeErrorMessage = T.append "splitFunTy : " $ toText flags typ + , typeErrorASTNodeName = astNode + } + modify' + (\st -> st { astStateTypeErrors = typeError : astStateTypeErrors st }) + return Nothing -- | Splits a type of a function of two arguments, adds -- 'TypeError' to 'ASTState' in case of a failure. -splitFunTy2Safe :: - SrcSpan -> T.Text -> Type -> State ASTState (Maybe (Type, Type, Type)) +splitFunTy2Safe + :: SrcSpan -> T.Text -> Type -> State ASTState (Maybe (Type, Type, Type)) splitFunTy2Safe srcSpan astNode typ = do tys <- splitFunTySafe srcSpan astNode typ case tys of @@ -261,7 +273,7 @@ splitFunTy2Safe srcSpan astNode typ = do res <- splitFunTySafe srcSpan astNode ty1 case res of Just (arg2, ty2) -> return $ Just (arg1, arg2, ty2) - Nothing -> return Nothing + Nothing -> return Nothing Nothing -> return Nothing -- | Returns result type of a function, adds 'TypeError' to @@ -277,7 +289,7 @@ funResultTy2Safe srcSpan astNode typ = do mbResTy1 <- funResultTySafe srcSpan astNode typ case mbResTy1 of Just resTy1 -> funResultTySafe srcSpan astNode resTy1 - Nothing -> return Nothing + Nothing -> return Nothing instance Ord FastString where a `compare` b = unpackFS a `compare` unpackFS b @@ -286,16 +298,15 @@ deriving instance () => Ord SrcLoc instance Ord SrcSpan where a `compare` b = - (srcSpanStart a `compare` srcSpanStart b) `thenCmp` - (srcSpanEnd a `compare` srcSpanEnd b) + (srcSpanStart a `compare` srcSpanStart b) + `thenCmp` (srcSpanEnd a `compare` srcSpanEnd b) -addIdentifierToIdSrcSpanMap :: - SrcSpan -> Id -> Maybe (Type, [Type]) -> State ASTState () -addIdentifierToIdSrcSpanMap span identifier mbTypes - | isGoodSrcSpan span = - modify' $ \astState@ASTState {astStateIdSrcSpanMap = ids} -> - let ids' = M.insert span (identifier, mbTypes) ids - in astState {astStateIdSrcSpanMap = ids'} +addIdentifierToIdSrcSpanMap + :: SrcSpan -> Id -> Maybe (Type, [Type]) -> State ASTState () +addIdentifierToIdSrcSpanMap span identifier mbTypes | isGoodSrcSpan span = + modify' $ \astState@ASTState { astStateIdSrcSpanMap = ids } -> + let ids' = M.insert span (identifier, mbTypes) ids + in astState { astStateIdSrcSpanMap = ids' } addIdentifierToIdSrcSpanMap _ _ _ = return () -- | Updates 'ExpressionInfoMap' or 'IdentifierOccurrenceMap' depending @@ -304,80 +315,76 @@ addExprInfo :: SrcSpan -> Maybe Type -> T.Text -> ExprSort -> State ASTState () addExprInfo span mbType descr sort = do transformation <- envTransformation . astStateEnv <$> get case srcSpanToLineAndColNumbers transformation span of - Just (_file,(startLine, startCol), (endLine, endCol)) -> do - flags <- envDynFlags . astStateEnv <$> get + Just (_file, (startLine, startCol), (endLine, endCol)) -> do + flags <- envDynFlags . astStateEnv <$> get mbHsWrapper <- astStateHsWrapper <$> get - modify' $ \astState@ASTState {astStateExprInfoMap = exprInfoMap} -> + modify' $ \astState@ASTState { astStateExprInfoMap = exprInfoMap } -> case sort of Composite -> - let exprInfo = - HCE.ExpressionInfo - {exprType = mkType flags <$> mbType, description = descr} + let exprInfo = HCE.ExpressionInfo + { exprType = mkType flags <$> mbType + , description = descr + } interval = IVM.OpenInterval (startLine, startCol) (endLine, endCol) exprInfoMap' = IVM.insert interval exprInfo exprInfoMap - in astState {astStateExprInfoMap = exprInfoMap'} + in astState { astStateExprInfoMap = exprInfoMap' } Simple -> - let idOcc = - HCE.IdentifierOccurrence - { internalId = Nothing - , internalIdFromRenamedSource = Nothing - , isBinder = False - , instanceResolution = Nothing - , idOccType = - case mbHsWrapper of - Just w -> mkType flags <$> (applyWrapper w <$> mbType) - Nothing -> mkType flags <$> mbType - , typeArguments = Nothing - , description = descr - , sort = HCE.ValueId - } - idOccMap = - IM.insertWith - removeOverlappingInterval - startLine - [((startCol, endCol), idOcc)] - (astStateIdOccMap astState) - in astState {astStateIdOccMap = idOccMap} + let + idOcc = HCE.IdentifierOccurrence + { internalId = Nothing + , internalIdFromRenamedSource = Nothing + , isBinder = False + , instanceResolution = Nothing + , idOccType = case mbHsWrapper of + Just w -> + mkType flags <$> (applyWrapper w <$> mbType) + Nothing -> mkType flags <$> mbType + , typeArguments = Nothing + , description = descr + , sort = HCE.ValueId + } + idOccMap = IM.insertWith removeOverlappingInterval + startLine + [((startCol, endCol), idOcc)] + (astStateIdOccMap astState) + in + astState { astStateIdOccMap = idOccMap } Nothing -> return () -- | Finds the first interval that overlaps with a new interval -- and adds the smaller one of the two to the list. If there are no overlapping -- intervals then this function adds a new interval to the list. -removeOverlappingInterval :: - forall a. [((Int, Int), a)] -> [((Int, Int), a)] -> [((Int, Int), a)] -removeOverlappingInterval [newInterval@((newStart, newEnd), _newVal)] intervals = - go intervals False - where - go :: - [((Int, Int), a)] - -> Bool -- If an overlapping interval is found - -> [((Int, Int), a)] - go (i:is) True = i : go is True - -- Current interval is inside new interval - go (interval@((s, e), _val):is) False - | newStart <= s && newEnd >= e = interval : go is True - -- New interval is inside current interval - go (((s, e), _val):is) False - | newStart >= s && newEnd <= e = newInterval : go is True - -- Intervals partially overlap - go (interval@((s, e), _val):is) False - | newStart >= s && newEnd >= e && newStart < e = - (if e - s >= newEnd - newStart - then newInterval - else interval) : - go is True - -- Intervals partially overlap - go (interval@((s, e), _val):is) False - | newStart <= s && newEnd <= e && newEnd > s = - (if e - s >= newEnd - newStart - then newInterval - else interval) : - go is True - -- Intervals don't overlap - go (interval:is) False = interval : go is False - go [] True = [] - go [] False = [newInterval] +removeOverlappingInterval + :: forall a . [((Int, Int), a)] -> [((Int, Int), a)] -> [((Int, Int), a)] +removeOverlappingInterval [newInterval@((newStart, newEnd), _newVal)] intervals + = go intervals False + where + go + :: [((Int, Int), a)] + -> Bool -- If an overlapping interval is found + -> [((Int, Int), a)] + go (i : is) True = i : go is True + -- Current interval is inside new interval + go (interval@((s, e), _val) : is) False | newStart <= s && newEnd >= e = + interval : go is True + -- New interval is inside current interval + go (((s, e), _val) : is) False | newStart >= s && newEnd <= e = + newInterval : go is True + -- Intervals partially overlap + go (interval@((s, e), _val) : is) False + | newStart >= s && newEnd >= e && newStart < e + = (if e - s >= newEnd - newStart then newInterval else interval) + : go is True + -- Intervals partially overlap + go (interval@((s, e), _val) : is) False + | newStart <= s && newEnd <= e && newEnd > s + = (if e - s >= newEnd - newStart then newInterval else interval) + : go is True + -- Intervals don't overlap + go (interval : is) False = interval : go is False + go [] True = [] + go [] False = [newInterval] removeOverlappingInterval _ intervals = intervals newtype InstTypes = InstTypes [Type] @@ -386,207 +393,197 @@ instance Eq InstTypes where (==) (InstTypes ts1) (InstTypes ts2) = eqTypes ts1 ts2 instance Ord InstTypes where -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) compare (InstTypes ts1) (InstTypes ts2) = nonDetCmpTypes ts1 ts2 -#else - compare (InstTypes ts1) (InstTypes ts2) = cmpTypes ts1 ts2 -#endif -- | Creates an instance resolution tree -traceInstanceResolution :: - Environment +traceInstanceResolution + :: Environment -> Class -> [Type] -- ^ Types at which type variables of a class are instantated -> HCE.InstanceResolution traceInstanceResolution environment c ts = go c ts S.empty - where - flags = envDynFlags environment - unitState = envUnitState environment - go :: Class -> [Type] -> S.Set (Name, InstTypes) -> HCE.InstanceResolution - go cls types seenInstances = - let clsTyVarCount = length $ classTyVars cls - in case lookupUniqueInstEnv - (envInstEnv environment) - cls - (take clsTyVarCount types) of - Right (inst, instTypes) -> - -- A successful match is a ClsInst, together with the types at which - -- the dfun_id in the ClsInst should be instantiated - let instWithTypes = (is_dfun_name inst, InstTypes instTypes) - in if not $ S.member instWithTypes seenInstances - then let (typeVars, predTypes, _class, _types) = - instanceSig inst - subst = zipTvSubst typeVars instTypes - constraints = - mapMaybe getClassPredTys_maybe . substTys subst $ - predTypes - in HCE.Instance - (instanceToText flags inst) - (mkType flags . idType $ is_dfun inst) - (map (mkType flags) instTypes) - (nameLocationInfo - unitState - (envPackageId environment) - (envComponentId environment) - (envTransformation environment) - (envFileMap environment) - (envDefSiteMap environment) - (Just . instanceToText flags $ inst) - Nothing - (varName . is_dfun $ inst)) - (map - (\(cl, tys) -> - go - cl - tys - (S.insert instWithTypes seenInstances)) - constraints) - else HCE.Stop - Left _ -> HCE.Stop + where + flags = envDynFlags environment + unitState = envUnitState environment + go :: Class -> [Type] -> S.Set (Name, InstTypes) -> HCE.InstanceResolution + go cls types seenInstances = + let clsTyVarCount = length $ classTyVars cls + in + case + lookupUniqueInstEnv (envInstEnv environment) + cls + (take clsTyVarCount types) + of + Right (inst, instTypes) -> + -- A successful match is a ClsInst, together with the types at which + -- the dfun_id in the ClsInst should be instantiated + let instWithTypes = (is_dfun_name inst, InstTypes instTypes) + in + if not $ S.member instWithTypes seenInstances + then + let + (typeVars, predTypes, _class, _types) = instanceSig inst + subst = zipTvSubst typeVars instTypes + constraints = + mapMaybe getClassPredTys_maybe . substTys subst $ predTypes + in + HCE.Instance + (instanceToText flags inst) + (mkType flags . idType $ is_dfun inst) + (map (mkType flags) instTypes) + (nameLocationInfo unitState + (envPackageId environment) + (envComponentId environment) + (envTransformation environment) + (envFileMap environment) + (envDefSiteMap environment) + (Just . instanceToText flags $ inst) + Nothing + (varName . is_dfun $ inst) + ) + (map + (\(cl, tys) -> + go cl tys (S.insert instWithTypes seenInstances) + ) + constraints + ) + else HCE.Stop + Left _ -> HCE.Stop mkIdentifierInfo :: Environment -> Id -> Maybe Name -> HCE.IdentifierInfo mkIdentifierInfo environment identifier mbNameFromRenamedSource = - let name = fromMaybe (varName identifier) mbNameFromRenamedSource - sort = nameSort name - nameSpace = occNameNameSpace . nameOccName $ name - flags = envDynFlags environment - unitState = envUnitState environment + let name = fromMaybe (varName identifier) mbNameFromRenamedSource + sort = nameSort name + nameSpace = occNameNameSpace . nameOccName $ name + flags = envDynFlags environment + unitState = envUnitState environment currentPackageId = envPackageId environment - compId = envComponentId environment - transformation = envTransformation environment - fileMap = envFileMap environment - defSiteMap = envDefSiteMap environment - locationInfo = - nameLocationInfo - unitState - currentPackageId - compId - transformation - fileMap - defSiteMap - Nothing - Nothing - name - in HCE.IdentifierInfo - { sort = sort - , occName = HCE.OccName $ nameToText name + compId = envComponentId environment + transformation = envTransformation environment + fileMap = envFileMap environment + defSiteMap = envDefSiteMap environment + locationInfo = nameLocationInfo unitState + currentPackageId + compId + transformation + fileMap + defSiteMap + Nothing + Nothing + name + in HCE.IdentifierInfo + { sort = sort + , occName = HCE.OccName $ nameToText name , demangledOccName = demangleOccName name - , nameSpace = nameSpace - , idType = mkType flags $ varType identifier - , locationInfo = locationInfo - , details = mbIdDetails identifier - , doc = - nameDocumentation - transformation - fileMap - defSiteMap - (envCurrentModuleDefSites environment) - name - , internalId = HCE.InternalId $ identifierKey flags identifier - , externalId = - case sort of - HCE.External -> - case locationInfo of - HCE.ExactLocation {..} -> - Just $ - HCE.ExternalId $ - T.intercalate - "|" - [ HCE.packageIdToText currentPackageId - , HCE.getHaskellModuleName moduleName - , case nameSpace of - HCE.VarName -> T.pack $ show HCE.Val - HCE.DataName -> T.pack $ show HCE.Val - _ -> T.pack $ show HCE.Typ - , nameToText name - ] - HCE.ApproximateLocation {name = n, ..} -> - Just $ - HCE.ExternalId $ - T.intercalate - "|" - [ HCE.packageIdToText packageId - , HCE.getHaskellModuleName moduleName - , T.pack $ show entity - , n - ] - _ -> Nothing - _ -> Nothing - , isExported = S.member name $ envExportedNames environment + , nameSpace = nameSpace + , idType = mkType flags $ varType identifier + , locationInfo = locationInfo + , details = mbIdDetails identifier + , doc = nameDocumentation transformation + fileMap + defSiteMap + (envCurrentModuleDefSites environment) + name + , internalId = HCE.InternalId $ identifierKey flags identifier + , externalId = case sort of + HCE.External -> case locationInfo of + HCE.ExactLocation {..} -> + Just $ HCE.ExternalId $ T.intercalate + "|" + [ HCE.packageIdToText currentPackageId + , HCE.getHaskellModuleName moduleName + , case nameSpace of + HCE.VarName -> T.pack $ show HCE.Val + HCE.DataName -> T.pack $ show HCE.Val + _ -> T.pack $ show HCE.Typ + , nameToText name + ] + HCE.ApproximateLocation { name = n, ..} -> + Just $ HCE.ExternalId $ T.intercalate + "|" + [ HCE.packageIdToText packageId + , HCE.getHaskellModuleName moduleName + , T.pack $ show entity + , n + ] + _ -> Nothing + _ -> Nothing + , isExported = S.member name $ envExportedNames environment } -mkIdentifierOccurrence :: - Environment +mkIdentifierOccurrence + :: Environment -> Id -> Name -> Maybe (Type, [Type]) -> Bool -> T.Text -> HCE.IdentifierOccurrence -mkIdentifierOccurrence environment identifier nameFromRenamedSource mbInstTypes isBinder descr = - let flags = envDynFlags environment - mbClass - | isId identifier = - case idDetails identifier of +mkIdentifierOccurrence environment identifier nameFromRenamedSource mbInstTypes isBinder descr + = let flags = envDynFlags environment + mbClass + | isId identifier = case idDetails identifier of ClassOpId cls -> Just cls - _ -> Nothing - | otherwise = Nothing - mbInstanceResolution = - case (mbClass, mbInstTypes) of + _ -> Nothing + | otherwise = Nothing + mbInstanceResolution = case (mbClass, mbInstTypes) of (Just cls, Just (_, ts)) -> Just $ traceInstanceResolution environment cls ts _ -> Nothing - in HCE.IdentifierOccurrence - (Just . HCE.InternalId . identifierKey flags $ identifier) - (Just . HCE.InternalId . T.pack . show . getKey . nameUnique $ nameFromRenamedSource) - isBinder - mbInstanceResolution - (mkType flags . fst <$> mbInstTypes) - (map (mkType flags) . snd <$> mbInstTypes) - descr - (if isId identifier - then HCE.ValueId - else HCE.TypeId) + in HCE.IdentifierOccurrence + (Just . HCE.InternalId . identifierKey flags $ identifier) + ( Just + . HCE.InternalId + . T.pack + . show + . getKey + . nameUnique + $ nameFromRenamedSource + ) + isBinder + mbInstanceResolution + (mkType flags . fst <$> mbInstTypes) + (map (mkType flags) . snd <$> mbInstTypes) + descr + (if isId identifier then HCE.ValueId else HCE.TypeId) restoreTidyEnv :: (State ASTState) a -> (State ASTState) a restoreTidyEnv action = do tidyEnv <- astStateTidyEnv <$> get - res <- action - modify' $ \s -> s {astStateTidyEnv = tidyEnv} + res <- action + modify' $ \s -> s { astStateTidyEnv = tidyEnv } return res tidyIdentifier :: Id -> State ASTState (Id, Maybe (Type, [Type])) tidyIdentifier identifier = do - tidyEnv <- astStateTidyEnv <$> get + tidyEnv <- astStateTidyEnv <$> get mbHsWrapper <- astStateHsWrapper <$> get - let (tidyEnv', identifier') = tidyIdentifierType tidyEnv identifier - identifierType = varType identifier' - (mbTypes, updatedEnv) = - case mbHsWrapper of - Just wrapper -> - let expectedType = applyWrapper wrapper identifierType - (tidyEnv'', expectedType') = tidyOpenType tidyEnv' expectedType - wrapperTys = - map (snd . tidyOpenType tidyEnv'') (wrapperTypes wrapper) - in if not $ eqType expectedType identifierType - then (Just (expectedType', wrapperTys), tidyEnv'') - else (Nothing, tidyEnv') - Nothing -> (Nothing, tidyEnv') - modify' (\s -> s {astStateTidyEnv = updatedEnv}) + let + (tidyEnv', identifier') = tidyIdentifierType tidyEnv identifier + identifierType = varType identifier' + (mbTypes, updatedEnv) = case mbHsWrapper of + Just wrapper -> + let + expectedType = applyWrapper wrapper identifierType + (tidyEnv'', expectedType') = tidyOpenType tidyEnv' expectedType + wrapperTys = + map (snd . tidyOpenType tidyEnv'') (wrapperTypes wrapper) + in + if not $ eqType expectedType identifierType + then (Just (expectedType', wrapperTys), tidyEnv'') + else (Nothing, tidyEnv') + Nothing -> (Nothing, tidyEnv') + modify' (\s -> s { astStateTidyEnv = updatedEnv }) return (identifier', mbTypes) tidyType :: Type -> State ASTState Type tidyType typ = do tidyEnv <- astStateTidyEnv <$> get let (tidyEnv', typ') = tidyOpenType tidyEnv typ - modify' (\s -> s {astStateTidyEnv = tidyEnv'}) + modify' (\s -> s { astStateTidyEnv = tidyEnv' }) return typ' -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foldTypecheckedSource :: LHsBinds GhcTc -> State ASTState () -#else -foldTypecheckedSource :: LHsBinds Id -> State ASTState () -#endif foldTypecheckedSource = foldLHsBindsLR -- src/HaskellCodeExplorer/AST/TypecheckedSource.hs:606:1: warning: [-Wincomplete-patterns] @@ -596,48 +593,39 @@ foldTypecheckedSource = foldLHsBindsLR -- L (GHC.Parser.Annotation.SrcSpanAnn _ _) (HsGetField _ _ _) -- L (GHC.Parser.Annotation.SrcSpanAnn _ _) (HsProjection _ _) foldLHsExpr :: LHsExpr GhcTc -> State ASTState (Maybe Type) -foldLHsExpr (L _span (XExpr _)) = return Nothing -foldLHsExpr lhe@(L _ (HsVar _ (L _ identifier))) = - restoreTidyEnv $ do - (identifier', mbTypes) <- tidyIdentifier identifier - addIdentifierToIdSrcSpanMap (getLocA lhe) identifier' mbTypes - return . Just . varType $ identifier' -foldLHsExpr (L _ HsUnboundVar {}) = return Nothing +foldLHsExpr ( L _span (XExpr _ )) = return Nothing +foldLHsExpr lhe@(L _ (HsVar _ (L _ identifier))) = restoreTidyEnv $ do + (identifier', mbTypes) <- tidyIdentifier identifier + addIdentifierToIdSrcSpanMap (getLocA lhe) identifier' mbTypes + return . Just . varType $ identifier' +foldLHsExpr (L _ HsUnboundVar{} ) = 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 +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 addExprInfo (getLocA lhe) Nothing "HsIPVar" (exprSort expr) return Nothing foldLHsExpr lhe@(L _ (HsOverLit _ (OverLit (OverLitTc _ ol_type) _ _))) = restoreTidyEnv $ do typ <- tidyType ol_type - addExprInfo - (getLocA lhe) - (Just typ) - "HsOverLit" - (if isOneLineSpan (getLocA lhe) - then Simple - else Composite) - return $ Just typ -foldLHsExpr lhe@(L _ (HsLit _ lit)) = - restoreTidyEnv $ do - typ <- tidyType $ hsLitType lit - addExprInfo - (getLocA lhe) - (Just typ) - "HsLit" - (if isOneLineSpan (getLocA lhe) - then Simple - else Composite) + addExprInfo (getLocA lhe) + (Just typ) + "HsOverLit" + (if isOneLineSpan (getLocA lhe) then Simple else Composite) return $ Just typ +foldLHsExpr lhe@(L _ (HsLit _ lit)) = restoreTidyEnv $ do + typ <- tidyType $ hsLitType lit + addExprInfo (getLocA lhe) + (Just typ) + "HsLit" + (if isOneLineSpan (getLocA lhe) then Simple else Composite) + return $ Just typ foldLHsExpr lhe@(L _ expr@(HsLam _ (MG (MatchGroupTc {..}) mg_alts _))) = restoreTidyEnv $ do typ <- tidyType $ mkVisFunTys mg_arg_tys mg_res_ty @@ -651,97 +639,90 @@ foldLHsExpr lhe@(L _ expr@(HsLamCase _ (MG (MatchGroupTc {..}) mg_alts _))) = mapM_ foldLMatch $ unLoc mg_alts return $ Just typ foldLHsExpr lhe@(L _ expr@(HsApp _ fun arg)) = do - funTy <- foldLHsExpr fun + funTy <- foldLHsExpr fun _argTy <- foldLHsExpr arg - typ <- maybe (return Nothing) (funResultTySafe (getLocA lhe) "HsApp") funTy + typ <- maybe (return Nothing) (funResultTySafe (getLocA lhe) "HsApp") funTy addExprInfo (getLocA lhe) typ "HsApp" (exprSort expr) return typ - + foldLHsExpr lhe@(L _ ex@(HsAppType _ expr _)) = do typ <- foldLHsExpr expr addExprInfo (getLocA lhe) typ "HsAppType" (exprSort ex) return typ foldLHsExpr lhe@(L _ expr@(OpApp _ left op right)) = do opTyp <- foldLHsExpr op - typ <- maybe (return Nothing) (funResultTy2Safe (getLocA lhe) "HsApp") opTyp - _ <- foldLHsExpr left - _ <- foldLHsExpr right + typ <- maybe (return Nothing) (funResultTy2Safe (getLocA lhe) "HsApp") opTyp + _ <- foldLHsExpr left + _ <- foldLHsExpr right addExprInfo (getLocA lhe) typ "OpApp" (exprSort expr) return typ foldLHsExpr lhe@(L _ e@(NegApp _ expr _syntaxExp)) = do typ <- foldLHsExpr expr addExprInfo (getLocA lhe) typ "NegApp" (exprSort e) return typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLHsExpr (L _span (HsPar _ expr)) = foldLHsExpr expr -#else -foldLHsExpr (L _span (HsPar expr)) = foldLHsExpr expr -#endif -foldLHsExpr lhe@(L _ expr@(SectionL _ operand operator)) = do - opType <- foldLHsExpr operator - _ <- foldLHsExpr operand - mbTypes <- maybe (return Nothing) (splitFunTy2Safe (getLocA lhe) "SectionL") opType - let typ = - case mbTypes of - Just (_arg1, arg2, res) -> Just $ mkVisFunTyMany arg2 res - Nothing -> Nothing +foldLHsExpr ( L _span ( HsPar _ expr )) = foldLHsExpr expr +foldLHsExpr lhe@(L _ expr@(SectionL _ operand operator)) = do + opType <- foldLHsExpr operator + _ <- foldLHsExpr operand + mbTypes <- maybe (return Nothing) + (splitFunTy2Safe (getLocA lhe) "SectionL") + opType + let typ = case mbTypes of + Just (_arg1, arg2, res) -> Just $ mkVisFunTyMany arg2 res + Nothing -> Nothing addExprInfo (getLocA lhe) typ "SectionL" (exprSort expr) return typ foldLHsExpr lhe@(L _ e@(SectionR _ operator operand)) = do - opType <- foldLHsExpr operator - _ <- foldLHsExpr operand - mbTypes <- maybe (return Nothing) (splitFunTy2Safe (getLocA lhe) "SectionR") opType - let typ = - case mbTypes of - Just (arg1, _arg2, res) -> Just $ mkVisFunTyMany arg1 res - Nothing -> Nothing + opType <- foldLHsExpr operator + _ <- foldLHsExpr operand + mbTypes <- maybe (return Nothing) + (splitFunTy2Safe (getLocA lhe) "SectionR") + opType + let typ = case mbTypes of + Just (arg1, _arg2, res) -> Just $ mkVisFunTyMany arg1 res + Nothing -> Nothing addExprInfo (getLocA lhe) typ "SectionR" (exprSort e) return typ foldLHsExpr lhe@(L _ e@(ExplicitTuple _ tupArgs boxity)) = do tupleArgs <- mapM foldHsTupArg tupArgs - let tupleSectionArgTys = - mapM fst . filter ((== TupArgMissing) . snd) $ tupleArgs - tupleArgTys = mapM fst tupleArgs - resultType = - mkVisFunTysMany <$> tupleSectionArgTys <*> (mkTupleTy boxity <$> tupleArgTys) + let + tupleSectionArgTys = + mapM fst . filter ((== TupArgMissing) . snd) $ tupleArgs + tupleArgTys = mapM fst tupleArgs + resultType = + mkVisFunTysMany + <$> tupleSectionArgTys + <*> (mkTupleTy boxity <$> tupleArgTys) tidyEnv <- astStateTidyEnv <$> get - addExprInfo - (getLocA lhe) - (snd . tidyOpenType tidyEnv <$> resultType) - "ExplicitTuple" - (exprSort e) + addExprInfo (getLocA lhe) + (snd . tidyOpenType tidyEnv <$> resultType) + "ExplicitTuple" + (exprSort e) return resultType -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLHsExpr (L _span (ExplicitSum _ _ _ expr)) = do -#else -foldLHsExpr (L _span (ExplicitSum _ _ expr _types)) = do -#endif -- TODO _ <- foldLHsExpr expr return Nothing -#endif foldLHsExpr lhe@(L _ e@(HsCase _ expr (MG (MatchGroupTc {..}) mg_alts _))) = restoreTidyEnv $ do typ <- tidyType mg_res_ty - _ <- foldLHsExpr expr + _ <- foldLHsExpr expr mapM_ foldLMatch (unLoc mg_alts) addExprInfo (getLocA lhe) (Just typ) "HsCase" (exprSort e) return $ Just typ foldLHsExpr lhe@(L _ e@(HsIf _ condExpr thenExpr elseExpr)) = do - _ <- foldLHsExpr condExpr + _ <- foldLHsExpr condExpr typ <- foldLHsExpr thenExpr - _ <- foldLHsExpr elseExpr + _ <- foldLHsExpr elseExpr addExprInfo (getLocA lhe) typ "HsIf" (exprSort e) return typ -foldLHsExpr lhe@(L _ e@(HsMultiIf typ grhss)) = - restoreTidyEnv $ do - typ' <- tidyType typ - addExprInfo (getLocA lhe) (Just typ') "HsMultiIf" (exprSort e) - mapM_ foldLGRHS grhss - return $ Just typ' +foldLHsExpr lhe@(L _ e@(HsMultiIf typ grhss)) = restoreTidyEnv $ do + typ' <- tidyType typ + addExprInfo (getLocA lhe) (Just typ') "HsMultiIf" (exprSort e) + mapM_ foldLGRHS grhss + return $ Just typ' foldLHsExpr lhe@(L _ e@(HsLet _ binds expr)) = do - _ <- foldHsLocalBindsLR binds + _ <- foldHsLocalBindsLR binds typ <- foldLHsExpr expr addExprInfo (getLocA lhe) typ "HsLet" (exprSort e) return typ @@ -751,23 +732,22 @@ foldLHsExpr lhe@(L _ expr@(HsDo typ _context (L _ stmts))) = addExprInfo (getLocA lhe) (Just typ') "HsDo" (exprSort expr) mapM_ foldLStmtLR stmts return $ Just typ' -foldLHsExpr lhe@(L _ (ExplicitList typ exprs)) = - restoreTidyEnv $ do - typ' <- mkListTy <$> tidyType typ - unless (null exprs) $ addExprInfo (getLocA lhe) (Just typ') "ExplicitList" Composite - mapM_ foldLHsExpr exprs - return $ Just typ' +foldLHsExpr lhe@(L _ (ExplicitList typ exprs)) = restoreTidyEnv $ do + typ' <- mkListTy <$> tidyType typ + unless (null exprs) + $ addExprInfo (getLocA lhe) (Just typ') "ExplicitList" Composite + mapM_ foldLHsExpr exprs + return $ Just typ' foldLHsExpr lhe@(L _ e@(RecordCon conExpr _ binds)) = do - mbConType <- - fmap (snd . splitFunTys) <$> - foldLHsExpr - (reLocA - (L (UnhelpfulSpan $ UnhelpfulOther $ mkFastString "RecordCon") conExpr)) - addExprInfo (getLocA lhe) mbConType "RecordCon" (exprSort e) - _ <- foldHsRecFields binds - return mbConType -foldLHsExpr lhe@(L _ e@(RecordUpd (RecordUpdTc cons _inputTys outTys _wrapper) expr binds)) = - restoreTidyEnv $ do + mbConType <- fmap (snd . splitFunTys) <$> foldLHsExpr + (reLocA + (L (UnhelpfulSpan $ UnhelpfulOther $ mkFastString "RecordCon") conExpr) + ) + addExprInfo (getLocA lhe) mbConType "RecordCon" (exprSort e) + _ <- foldHsRecFields binds + return mbConType +foldLHsExpr lhe@(L _ e@(RecordUpd (RecordUpdTc cons _inputTys outTys _wrapper) expr binds)) + = restoreTidyEnv $ do -- cons is a non-empty list of DataCons that have all the upd'd fields let typ = conLikeResTy (head cons) outTys typ' <- tidyType typ @@ -780,29 +760,27 @@ foldLHsExpr lhe@(L _ e@(ExprWithTySig _ expr _)) = do addExprInfo (getLocA lhe) typ "ExprWithTySig" (exprSort e) return typ foldLHsExpr lhe@(L _ e@(ArithSeq postTcExpr _mbSyntaxExpr seqInfo)) = do - typ <- - fmap (snd . splitFunTys . snd . splitForAllTyCoVars) <$> - foldLHsExpr + typ <- fmap (snd . splitFunTys . snd . splitForAllTyCoVars) <$> foldLHsExpr (reLocA - (L (UnhelpfulSpan $ UnhelpfulOther $ mkFastString "ArithSeq") postTcExpr)) - _ <- - case seqInfo of - From expr -> foldLHsExpr expr - FromThen expr1 expr2 -> foldLHsExpr expr1 >> foldLHsExpr expr2 - FromTo expr1 expr2 -> foldLHsExpr expr1 >> foldLHsExpr expr2 - FromThenTo expr1 expr2 expr3 -> - foldLHsExpr expr1 >> foldLHsExpr expr2 >> foldLHsExpr expr3 + (L (UnhelpfulSpan $ UnhelpfulOther $ mkFastString "ArithSeq") postTcExpr) + ) + _ <- case seqInfo of + From expr -> foldLHsExpr expr + FromThen expr1 expr2 -> foldLHsExpr expr1 >> foldLHsExpr expr2 + FromTo expr1 expr2 -> foldLHsExpr expr1 >> foldLHsExpr expr2 + FromThenTo expr1 expr2 expr3 -> + foldLHsExpr expr1 >> foldLHsExpr expr2 >> foldLHsExpr expr3 addExprInfo (getLocA lhe) typ "ArithSeq" (exprSort e) return typ -foldLHsExpr lhe@(L _ e@(HsPragE _ (HsPragSCC {}) expr)) = do +foldLHsExpr lhe@(L _ e@(HsPragE _ (HsPragSCC{}) expr)) = do typ <- foldLHsExpr expr addExprInfo (getLocA lhe) typ "HsSCC" (exprSort e) return typ -foldLHsExpr (L _span HsBracket {}) = return Nothing -foldLHsExpr (L _span HsRnBracketOut {}) = return Nothing -foldLHsExpr (L _span HsTcBracketOut {}) = return Nothing -foldLHsExpr (L _span HsSpliceE {}) = return Nothing -foldLHsExpr lhe@(L _ expr@(HsProc _ pat cmd)) = do +foldLHsExpr ( L _span HsBracket{} ) = return Nothing +foldLHsExpr ( L _span HsRnBracketOut{} ) = return Nothing +foldLHsExpr ( L _span HsTcBracketOut{} ) = return Nothing +foldLHsExpr ( L _span HsSpliceE{} ) = return Nothing +foldLHsExpr lhe@(L _ expr@(HsProc _ pat cmd)) = do _ <- foldLPat pat _ <- foldLHsCmdTop cmd addExprInfo (getLocA lhe) Nothing "HsProc" (exprSort expr) @@ -820,21 +798,25 @@ foldLHsExpr lhe@(L _ e@(HsBinTick _ _ _ expr)) = do addExprInfo (getLocA lhe) typ "HsBinTick" (exprSort e) return typ -foldHsRecFields :: HsRecFields GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +foldHsRecFields + :: HsRecFields GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) foldHsRecFields HsRecFields {..} = do - let userWritten = - case rec_dotdot of - Just i -> take $ unLoc i - Nothing -> id + let userWritten = case rec_dotdot of + Just i -> take $ unLoc i + Nothing -> id mapM_ foldLHsRecField $ userWritten rec_flds return Nothing -foldLHsRecField :: LHsRecField GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) -foldLHsRecField lhr@(L _ (HsRecField _ (L idSpan (FieldOcc identifier _)) arg pun)) = - restoreTidyEnv $ do +foldLHsRecField + :: LHsRecField GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +foldLHsRecField lhr@(L _ (HsRecField _ (L idSpan (FieldOcc identifier _)) arg pun)) + = restoreTidyEnv $ do (identifier', mbTypes) <- tidyIdentifier identifier addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes - addExprInfo (getLocA lhr) (Just . varType $ identifier') "HsRecField" Composite + addExprInfo (getLocA lhr) + (Just . varType $ identifier') + "HsRecField" + Composite unless pun $ void (foldLHsExpr arg) return . Just . varType $ identifier' @@ -845,15 +827,17 @@ foldLHsRecUpdField lhr@(L _ (HsRecField _ (L idSpan recField) arg pun)) = (identifier', mbTypes) <- tidyIdentifier selectorId -- Name of the selectorId is not 'correct' (Internal instead of External) : -- https://github.com/ghc/ghc/blob/321b420f4582d103ca7b304867b916a749712e9f/compiler/typecheck/TcExpr.hs#L2424 - typeEnv <- envTypeEnv . astStateEnv <$> get - let selName = varName selectorId - originalName = - case lookupTypeEnv typeEnv selName of - Just (AnId originalSelId) -> varName originalSelId - _ -> selName + typeEnv <- envTypeEnv . astStateEnv <$> get + let selName = varName selectorId + originalName = case lookupTypeEnv typeEnv selName of + Just (AnId originalSelId) -> varName originalSelId + _ -> selName let identifier'' = setVarName identifier' originalName addIdentifierToIdSrcSpanMap idSpan identifier'' mbTypes - addExprInfo (getLocA lhr) (Just . varType $ identifier'') "HsRecUpdField" Composite + addExprInfo (getLocA lhr) + (Just . varType $ identifier'') + "HsRecUpdField" + Composite unless pun $ void (foldLHsExpr arg) return . Just . varType $ identifier' @@ -863,69 +847,47 @@ data TupArg deriving (Show, Eq) foldHsTupArg :: HsTupArg GhcTc -> State ASTState (Maybe Type, TupArg) -foldHsTupArg (Present _ expr) = - restoreTidyEnv $ do - typ <- foldLHsExpr expr - typ' <- - case typ of - Just t -> Just <$> tidyType t - Nothing -> return Nothing - return (typ', TupArgPresent) -foldHsTupArg (Missing typ) = - restoreTidyEnv $ do - typ' <- tidyType $ scaledThing typ - return (Just typ', TupArgMissing) +foldHsTupArg (Present _ expr) = restoreTidyEnv $ do + typ <- foldLHsExpr expr + typ' <- case typ of + Just t -> Just <$> tidyType t + Nothing -> return Nothing + return (typ', TupArgPresent) +foldHsTupArg (Missing typ) = restoreTidyEnv $ do + typ' <- tidyType $ scaledThing typ + return (Just typ', TupArgMissing) -#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 _ <- foldGRHSs m_grhss return Nothing -#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 _ <- foldGRHSsCmd m_grhss return Nothing -#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 _ <- foldHsLocalBindsLR grhssLocalBinds return Nothing -#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 _ <- foldHsLocalBindsLR grhssLocalBinds return Nothing -foldLStmtLR :: LStmtLR GhcTc GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) -foldLStmtLR lst@(L _ (LastStmt _ body _ _)) = - do typ <- foldLHsExpr body - addExprInfo (getLocA lst) typ "LastStmt" Composite - return typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) +foldLStmtLR + :: LStmtLR GhcTc GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) +foldLStmtLR lst@(L _ (LastStmt _ body _ _)) = do + typ <- foldLHsExpr body + addExprInfo (getLocA lst) typ "LastStmt" Composite + return typ foldLStmtLR (L _span (BindStmt _ pat body)) = do -#else -foldLStmtLR (L _span (BindStmt pat body _ _ _)) = do -#endif _ <- foldLPat pat _ <- foldLHsExpr body return Nothing @@ -933,18 +895,10 @@ foldLStmtLR lst@(L _ (BodyStmt _ body _ _)) = do mbTyp <- foldLHsExpr body addExprInfo (getLocA lst) mbTyp "BodyStmt" Composite return mbTyp -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLStmtLR (L _ (LetStmt _ binds)) = do -#else -foldLStmtLR (L _ (LetStmt (L _ binds))) = do -#endif _ <- foldHsLocalBindsLR binds return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLStmtLR (L _ (ParStmt _ blocks _ _)) = do -#else -foldLStmtLR (L _ (ParStmt blocks _ _ _)) = do -#endif mapM_ foldParStmtBlock blocks return Nothing foldLStmtLR (L _ TransStmt {..}) = do @@ -955,36 +909,24 @@ foldLStmtLR (L _ TransStmt {..}) = do foldLStmtLR (L _span RecStmt {..}) = do mapM_ foldLStmtLR (unLoc recS_stmts) return Nothing -foldLStmtLR lslr@(L _ (ApplicativeStmt typ args _)) = - restoreTidyEnv $ do - typ' <- tidyType typ - mapM_ (foldApplicativeArg . snd) args - addExprInfo (getLocA lslr) (Just typ') "ApplicativeStmt" Composite - return Nothing +foldLStmtLR lslr@(L _ (ApplicativeStmt typ args _)) = restoreTidyEnv $ do + typ' <- tidyType typ + mapM_ (foldApplicativeArg . snd) args + addExprInfo (getLocA lslr) (Just typ') "ApplicativeStmt" Composite + return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldApplicativeArg :: ApplicativeArg GhcTc -> State ASTState (Maybe Type) -#elif 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 - ApplicativeArgOne _ pat expr _bool -> do - _ <- foldLPat pat - _ <- foldLHsExpr expr - return Nothing - ApplicativeArgMany _ exprStmts _ pat _ -> do - mapM_ foldLStmtLR exprStmts - _ <- foldLPat pat - return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -foldLStmtLRCmd :: - LStmtLR GhcTc GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type) -#else -foldLStmtLRCmd :: LStmtLR Id Id (LHsCmd Id) -> State ASTState (Maybe Type) -#endif +foldApplicativeArg appArg = case appArg of + ApplicativeArgOne _ pat expr _bool -> do + _ <- foldLPat pat + _ <- foldLHsExpr expr + return Nothing + ApplicativeArgMany _ exprStmts _ pat _ -> do + mapM_ foldLStmtLR exprStmts + _ <- foldLPat pat + return Nothing +foldLStmtLRCmd + :: LStmtLR GhcTc GhcTc (LHsCmd GhcTc) -> State ASTState (Maybe Type) foldLStmtLRCmd ls@(L _ (LastStmt _ body _syntaxExpr _)) = do typ <- foldLHsCmd body addExprInfo (getLocA ls) typ "LastStmt Cmd" Composite @@ -1000,11 +942,7 @@ foldLStmtLRCmd ls@(L _ (BodyStmt _ body _ _)) = do foldLStmtLRCmd (L _ (LetStmt _ binds)) = do _ <- foldHsLocalBindsLR binds return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLStmtLRCmd (L _ (ParStmt _ blocks _ _)) = do -#else -foldLStmtLRCmd (L _ (ParStmt blocks _ _ _)) = do -#endif mapM_ foldParStmtBlock blocks return Nothing foldLStmtLRCmd (L _ TransStmt {..}) = do @@ -1015,12 +953,11 @@ foldLStmtLRCmd (L _ TransStmt {..}) = do foldLStmtLRCmd (L _ RecStmt {..}) = do mapM_ foldLStmtLRCmd (unLoc recS_stmts) return Nothing -foldLStmtLRCmd ls@(L _ (ApplicativeStmt typ args _)) = - restoreTidyEnv $ do - typ' <- tidyType typ - mapM_ (foldApplicativeArg . snd) args - addExprInfo (getLocA ls) (Just typ') "ApplicativeStmt Cmd" Composite - return Nothing +foldLStmtLRCmd ls@(L _ (ApplicativeStmt typ args _)) = restoreTidyEnv $ do + typ' <- tidyType typ + mapM_ (foldApplicativeArg . snd) args + addExprInfo (getLocA ls) (Just typ') "ApplicativeStmt Cmd" Composite + return Nothing foldLGRHS :: LGRHS GhcTc (LHsExpr GhcTc) -> State ASTState (Maybe Type) foldLGRHS (L _span (GRHS _ guards body)) = do @@ -1043,88 +980,67 @@ foldHsLocalBindsLR :: HsLocalBindsLR GhcTc GhcTc -> State ASTState (Maybe Type) foldHsLocalBindsLR (HsValBinds _ binds) = do _ <- foldHsValBindsLR binds return Nothing -foldHsLocalBindsLR HsIPBinds {} = return Nothing -foldHsLocalBindsLR EmptyLocalBinds {} = return Nothing +foldHsLocalBindsLR HsIPBinds{} = return Nothing +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 -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldHsValBindsLR (ValBinds _ _binds _) = do return Nothing foldHsValBindsLR (XValBindsLR (NValBinds binds _)) = do _ <- mapM_ (foldLHsBindsLR . snd) binds return Nothing -#else -foldHsValBindsLR (ValBindsIn _ _) = return Nothing -foldHsValBindsLR (ValBindsOut binds _) = do - mapM_ (foldLHsBindsLR . snd) binds - return Nothing -#endif foldLHsBindsLR :: LHsBinds GhcTc -> State ASTState () foldLHsBindsLR = mapM_ (`foldLHsBindLR` Nothing) . bagToList -foldLHsBindLR :: LHsBindLR GhcTc GhcTc - -> Maybe Id -- ^ Polymorphic id - -> State ASTState (Maybe Type) +foldLHsBindLR + :: LHsBindLR GhcTc GhcTc + -> Maybe Id -- ^ Polymorphic id + -> State ASTState (Maybe Type) foldLHsBindLR (L _span FunBind {..}) mbPolyId - | mg_origin fun_matches == FromSource = - restoreTidyEnv $ do - let fi@(L _ identifier) = fun_id -- monotype - typ = - case mbPolyId of - Just polyId -> varType polyId - Nothing -> varType identifier - name = maybe (varName identifier) varName mbPolyId - identifier' = setVarType (setVarName identifier name) typ - (identifier'', _) <- tidyIdentifier identifier' - addIdentifierToIdSrcSpanMap (getLocA fi) identifier'' Nothing - mapM_ foldLMatch (unLoc (mg_alts fun_matches)) - return Nothing + | mg_origin fun_matches == FromSource = restoreTidyEnv $ do + let fi@(L _ identifier) = fun_id -- monotype + typ = case mbPolyId of + Just polyId -> varType polyId + Nothing -> varType identifier + name = maybe (varName identifier) varName mbPolyId + identifier' = setVarType (setVarName identifier name) typ + (identifier'', _) <- tidyIdentifier identifier' + addIdentifierToIdSrcSpanMap (getLocA fi) identifier'' Nothing + mapM_ foldLMatch (unLoc (mg_alts fun_matches)) + return Nothing | otherwise = return Nothing foldLHsBindLR (L _ PatBind {..}) _ = do _ <- foldLPat pat_lhs _ <- foldGRHSs pat_rhs return Nothing -foldLHsBindLR (L _ VarBind {}) _ = return Nothing +foldLHsBindLR (L _ VarBind{} ) _ = return Nothing foldLHsBindLR (L _ AbsBinds {..}) _ = do - mapM_ (\(bind, typ) -> foldLHsBindLR bind (Just typ)) $ - zip (bagToList abs_binds) (map abe_poly abs_exports) + 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) +foldLHsBindLR (L _ (PatSynBind _ PSB {..})) _ = restoreTidyEnv $ do + _ <- foldLPat psb_def + _ <- + let addId :: GenLocated SrcSpan Id -> State ASTState () + addId (L span i) = do + (i', _) <- tidyIdentifier i + addIdentifierToIdSrcSpanMap span i' Nothing + in case psb_args of + InfixCon id1 id2 -> addId (reLocN id1) >> addId (reLocN id2) + PrefixCon _ ids -> mapM_ (addId . reLocN) ids + RecCon recs -> mapM_ + (\(RecordPatSynField field patVar) -> + addId (L ((getLocA . rdrNameFieldOcc) field) (extFieldOcc field)) + >> addId (reLocN patVar) + ) + recs return Nothing -#endif -foldLHsBindLR (L _ (PatSynBind _ PSB {..})) _ = - restoreTidyEnv $ do - _ <- foldLPat psb_def - _ <- - let addId :: GenLocated SrcSpan Id -> State ASTState () - addId (L span i) = do - (i', _) <- tidyIdentifier i - addIdentifierToIdSrcSpanMap span i' Nothing - in case psb_args of - InfixCon id1 id2 -> addId (reLocN id1) >> addId (reLocN id2) - PrefixCon _ ids -> mapM_ (addId . reLocN) ids - RecCon recs -> - mapM_ - (\(RecordPatSynField field patVar) -> - addId - (L ((getLocA . rdrNameFieldOcc) field) - (extFieldOcc field)) - >> addId (reLocN patVar)) - recs - return Nothing foldLPat :: LPat GhcTc -> State ASTState (Maybe Type) -foldLPat (L _span (XPat _)) = return Nothing -foldLPat lp@(L _ (VarPat _ (L _ identifier))) = do +foldLPat ( L _span (XPat _ )) = return Nothing +foldLPat lp@(L _ (VarPat _ (L _ identifier))) = do (identifier', _) <- tidyIdentifier identifier addIdentifierToIdSrcSpanMap (getLocA lp) identifier' Nothing return . Just . varType $ identifier' @@ -1142,56 +1058,26 @@ foldLPat lp@(L _ p@(AsPat _ ide@(L _ identifier) pat)) = do addExprInfo (getLocA lp) (Just . varType $ identifier') "AsPat" (patSort p) _ <- foldLPat pat return . Just . varType $ identifier' -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat (L _span (ParPat _ pat)) = foldLPat pat -#else -foldLPat (L _span (ParPat pat)) = foldLPat pat -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat lp@(L _ p@(BangPat _ pat)) = do -#else -foldLPat lp@(L _ p@(BangPat pat)) = do -#endif +foldLPat ( L _span ( ParPat _ pat)) = foldLPat pat +foldLPat lp@(L _ p@(BangPat _ pat)) = do typ <- foldLPat pat addExprInfo (getLocA lp) typ "BangPat" (patSort p) return typ -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLPat lp@(L _ p@(ListPat (ListPatTc typ _) pats)) = do -#else -foldLPat lp@(L _ p@(ListPat pats typ _)) = do -#endif typ' <- tidyType typ let listType = mkListTy typ' addExprInfo (getLocA lp) (Just listType) "ListPat" (patSort p) mapM_ foldLPat pats return $ Just listType -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLPat lp@(L _ pat@(TuplePat types pats boxity)) = do -#else -foldLPat lp@(L _ pat@(TuplePat pats boxity types)) = do -#endif typ' <- tidyType $ mkTupleTy boxity types addExprInfo (getLocA lp) (Just typ') "TuplePat" (patSort pat) mapM_ foldLPat pats return $ Just typ' -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) foldLPat (L _span (SumPat _ pat _ _)) = do -#else -foldLPat (L _span (SumPat pat _ _ _types)) = do -#endif -- TODO _ <- foldLPat pat return Nothing -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -#else -foldLPat lp@(L _ pat@(PArrPat pats typ)) = do - typ' <- tidyType typ - addExprInfo (getLocA lp) (Just typ') "PArrPat" (patSort pat) - mapM_ foldLPat pats - return $ Just typ' -#endif -- no more conpatin / conpatout, just conpat (in the wildcard pattern _) -- foldLPat (ghcDL -> L _span (ConPatIn _ _)) = return Nothing -- TODO: FIXME @@ -1214,60 +1100,35 @@ foldLPat lp@(L _ p@(ViewPat typ expr pat)) = do _ <- foldLPat pat _ <- foldLHsExpr expr return $ Just typ' -foldLPat (L _ SplicePat {}) = return Nothing -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) +foldLPat ( L _ SplicePat{} ) = return Nothing foldLPat lp@(L _ (LitPat _ hsLit)) = do -#else -foldLPat lp@(L _ (LitPat hsLit)) = do -#endif typ' <- tidyType $ hsLitType hsLit - addExprInfo - (getLocA lp) - (Just typ') - "LitPat" - (if isOneLineSpan (getLocA lp) - then Simple - else Composite) - return $ Just typ' -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat lp@(L _ pat@(NPat _ (L _spanLit (OverLit (OverLitTc {..}) _ _)) _ _)) = do -#else -foldLPat lp@(L _ pat@(NPat (L _spanLit OverLit {ol_type}) _ _ _)) = do -#endif - typ' <- tidyType ol_type - addExprInfo (getLocA lp) (Just typ') "NPat" (patSort pat) - return $ Just ol_type -foldLPat lp@(L _ pat@(NPlusKPat typ ide@(L _ identifier) (L litSpan (OverLit (OverLitTc {..}) _ _)) _ _ _)) = do - (identifier', _) <- tidyIdentifier identifier - addIdentifierToIdSrcSpanMap (getLocA ide) identifier' Nothing - typ' <- tidyType typ - addExprInfo (getLocA lp) (Just typ') "NPlusKPat" (patSort pat) - olType' <- tidyType ol_type - addExprInfo - litSpan - (Just olType') - "NPlusKPat" - (if isOneLineSpan (getLocA lp) - then Simple - else Composite) - return $ Just typ' -#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) -foldLPat (L _span (SigPat typ pat _)) = do - typ' <- tidyType typ - _ <- foldLPat pat - return $ Just typ' -#elif MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -foldLPat (L _span (SigPat typ pat)) = do - typ' <- tidyType typ - _ <- foldLPat pat + addExprInfo (getLocA lp) + (Just typ') + "LitPat" + (if isOneLineSpan (getLocA lp) then Simple else Composite) return $ Just typ' -#else -foldLPat (L _span (SigPatIn _ _)) = return Nothing -foldLPat (L _span (SigPatOut pat typ)) = do +foldLPat lp@(L _ pat@(NPat _ (L _spanLit (OverLit (OverLitTc {..}) _ _)) _ _)) + = do + typ' <- tidyType ol_type + addExprInfo (getLocA lp) (Just typ') "NPat" (patSort pat) + return $ Just ol_type +foldLPat lp@(L _ pat@(NPlusKPat typ ide@(L _ identifier) (L litSpan (OverLit (OverLitTc {..}) _ _)) _ _ _)) + = do + (identifier', _) <- tidyIdentifier identifier + addIdentifierToIdSrcSpanMap (getLocA ide) identifier' Nothing + typ' <- tidyType typ + addExprInfo (getLocA lp) (Just typ') "NPlusKPat" (patSort pat) + olType' <- tidyType ol_type + addExprInfo litSpan + (Just olType') + "NPlusKPat" + (if isOneLineSpan (getLocA lp) then Simple else Composite) + return $ Just typ' +foldLPat (L _span (SigPat typ pat _)) = do typ' <- tidyType typ - _ <- foldLPat pat + _ <- foldLPat pat return $ Just typ' -#endif foldLPat _ = return Nothing foldLHsCmdTop :: LHsCmdTop GhcTc -> State ASTState (Maybe Type) @@ -1282,12 +1143,12 @@ foldLHsCmdTop (L span (HsCmdTop _ cmd)) = do -- Patterns of type ‘LHsCmd GhcTc’ not matched: -- L (GHC.Parser.Annotation.SrcSpanAnn _ _) (HsCmdLamCase _ _) foldLHsCmd :: LHsCmd GhcTc -> State ASTState (Maybe Type) -foldLHsCmd (L _ (XCmd _)) = return Nothing +foldLHsCmd (L _ (XCmd _ )) = return Nothing foldLHsCmd (L _ (HsCmdArrApp _ expr1 expr2 _ _)) = do _ <- foldLHsExpr expr1 _ <- foldLHsExpr expr2 return Nothing -foldLHsCmd (L _ (HsCmdArrForm _ expr _ _ topCmds)) = do +foldLHsCmd (L _ (HsCmdArrForm _ expr _ _ topCmds)) = do _ <- foldLHsExpr expr mapM_ foldLHsCmdTop topCmds return Nothing 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 "") 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 diff --git a/src/HaskellCodeExplorer/ModuleInfo.hs b/src/HaskellCodeExplorer/ModuleInfo.hs index 6f5c9b5..5aeb6bd 100644 --- a/src/HaskellCodeExplorer/ModuleInfo.hs +++ b/src/HaskellCodeExplorer/ModuleInfo.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} @@ -14,306 +13,344 @@ module HaskellCodeExplorer.ModuleInfo , ModuleDependencies ) where -import qualified Data.Generics.Uniplate.Data as U -import Control.Monad.State.Strict (execState,evalState,get,put,State) -import qualified Data.Aeson as Aeson -import Data.Aeson.Text(encodeToLazyText) -import qualified Data.Vector as V -import qualified Data.HashMap.Strict as HM -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 GHC.Hs.Extension (GhcRn) -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Data.Text.Lazy (toStrict) -import Documentation.Haddock.Types (DocH) -import GHC - ( GenLocated(..) - , DynFlags - , LHsBindLR - , ModSummary - , ModuleInfo - , ModuleName - , SrcSpan - , TyThing(..) - , Type - , TypecheckedModule - , getLoc - , isGoodSrcSpan - , modInfoExportsWithSelectors - , modInfoInstances - , moduleInfo - , moduleNameString - , ms_hspp_buf - , ms_mod - , renamedSource - , tm_internals_ - , tm_typechecked_source - , unLoc - , LHsDecl - ) -import GHC.Parser.Annotation (sortLocatedA, getLocA) -import GHC.Core.Type(expandTypeSynonyms) -import GHC.Core.TyCon (isFamInstTyCon,tyConName) -import HaskellCodeExplorer.AST.RenamedSource -import HaskellCodeExplorer.AST.TypecheckedSource -import HaskellCodeExplorer.GhcUtils -import HaskellCodeExplorer.Preprocessor (createSourceCodeTransformation) -import qualified HaskellCodeExplorer.Types as HCE -import GHC.Hs.Decls - ( ForeignDecl(..) - , HsDecl(..) - , HsGroup(..) - , LInstDecl - , LForeignDecl - , LTyClDecl - , InstDecl(..) - , group_tyclds - , tyClDeclLName - , tcdName - , hsGroupInstDecls - ) -import GHC.Hs.Doc(HsDocString) -import GHC.Hs.ImpExp (IE(..), ImportDecl(..)) -import GHC.Hs.Utils - ( collectHsBindBinders - , CollectFlag(..) - ) -import GHC.Unit.State (UnitState) -import GHC.Unit.Module.ModDetails - ( md_types - ) -import GHC.Unit.External - ( ExternalPackageState - , eps_PTE - , eps_inst_env - ) -import GHC.Unit.Home.ModInfo - ( HomePackageTable - , hm_details - ) -import GHC.Core.InstEnv (InstEnvs(..), is_dfun) -import GHC.Unit.Types - ( GenModule(..) - ) -import GHC.Types.Name (Name, OccName, getSrcSpan, nameOccName, nameSrcSpan, nameUnique) -import Prelude hiding(id,span) -import GHC.Types.TypeEnv - ( TypeEnv - , typeEnvElts - , mkTypeEnv - ) -import GHC.Types.Name.Reader (GlobalRdrEnv) -import GHC.Types.SrcLoc (isOneLineSpan) -import GHC.Tc.Types (tcVisibleOrphanMods, tcg_inst_env, tcg_rdr_env, tcg_type_env) -import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as A -import GHC.Types.Unique.DFM (eltsUDFM) -import GHC.Types.Unique (getKey) -import GHC.Types.Var (varName, varType,Id) -import GHC.Types.Var.Env (emptyTidyEnv) +import Control.Monad.State.Strict ( State + , evalState + , execState + , get + , put + ) +import qualified Data.Aeson as Aeson +import Data.Aeson.Text ( encodeToLazyText ) +import qualified Data.Generics.Uniplate.Data as U +import qualified Data.HashMap.Strict as HM +import qualified Data.IntMap.Strict as IM +import qualified Data.IntervalMap.Strict as IVM +import qualified Data.List as L + hiding ( span ) +import qualified Data.Map.Strict as M +import Data.Maybe ( fromMaybe + , mapMaybe + ) +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Text.Lazy ( toStrict ) +import qualified Data.Vector as V +import Documentation.Haddock.Types ( DocH ) +import GHC ( DynFlags + , GenLocated(..) + , LHsBindLR + , LHsDecl + , ModSummary + , ModuleInfo + , ModuleName + , SrcSpan + , TyThing(..) + , Type + , TypecheckedModule + , getLoc + , isGoodSrcSpan + , modInfoExportsWithSelectors + , modInfoInstances + , moduleInfo + , moduleNameString + , ms_hspp_buf + , ms_mod + , renamedSource + , tm_internals_ + , tm_typechecked_source + , unLoc + ) +import GHC.Core.InstEnv ( InstEnvs(..) + , is_dfun + ) +import GHC.Core.TyCon ( isFamInstTyCon + , tyConName + ) +import GHC.Core.Type ( expandTypeSynonyms ) +import GHC.Hs.Decls ( ForeignDecl(..) + , HsDecl(..) + , HsGroup(..) + , InstDecl(..) + , LForeignDecl + , LInstDecl + , LTyClDecl + , group_tyclds + , hsGroupInstDecls + , tcdName + , tyClDeclLName + ) +import GHC.Hs.Doc ( HsDocString ) +import GHC.Hs.Extension ( GhcRn ) +import GHC.Hs.ImpExp ( IE(..) + , ImportDecl(..) + ) +import GHC.Hs.Utils ( CollectFlag(..) + , collectHsBindBinders + ) +import GHC.Parser.Annotation ( getLocA + , sortLocatedA + ) +import GHC.Tc.Types ( tcVisibleOrphanMods + , tcg_inst_env + , tcg_rdr_env + , tcg_type_env + ) +import GHC.Types.Name ( Name + , OccName + , getSrcSpan + , nameOccName + , nameSrcSpan + , nameUnique + ) +import GHC.Types.Name.Reader ( GlobalRdrEnv ) +import GHC.Types.SrcLoc ( isOneLineSpan ) +import GHC.Types.TypeEnv ( TypeEnv + , mkTypeEnv + , typeEnvElts + ) +import GHC.Types.Unique ( getKey ) +import GHC.Types.Unique.DFM ( eltsUDFM ) +import GHC.Types.Var ( Id + , varName + , varType + ) +import GHC.Types.Var.Env ( emptyTidyEnv ) +import GHC.Unit.External ( ExternalPackageState + , eps_PTE + , eps_inst_env + ) +import GHC.Unit.Home.ModInfo ( HomePackageTable + , hm_details + ) +import GHC.Unit.Module.ModDetails ( md_types ) +import GHC.Unit.State ( UnitState ) +import GHC.Unit.Types ( GenModule(..) ) +import HaskellCodeExplorer.AST.RenamedSource +import HaskellCodeExplorer.AST.TypecheckedSource +import HaskellCodeExplorer.GhcUtils +import HaskellCodeExplorer.Preprocessor + ( createSourceCodeTransformation + ) +import qualified HaskellCodeExplorer.Types as HCE +import Prelude hiding ( id + , span + ) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A type ModuleDependencies - = ( HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath - , HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap - , HM.HashMap HCE.HaskellModuleName (HM.HashMap HCE.ComponentId HCE.HaskellModulePath)) + = ( HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath + , HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap + , HM.HashMap + HCE.HaskellModuleName + (HM.HashMap HCE.ComponentId HCE.HaskellModulePath) + ) type ModuleGhcData - = ( DynFlags - , UnitState - , TypecheckedModule - , HomePackageTable - , ExternalPackageState - , ModSummary) + = ( DynFlags + , UnitState + , TypecheckedModule + , HomePackageTable + , ExternalPackageState + , ModSummary + ) -createModuleInfo :: - ModuleDependencies -- ^ Modules that have already been indexed +createModuleInfo + :: ModuleDependencies -- ^ Modules that have already been indexed -> ModuleGhcData -- ^ Data types from GHC -> HCE.HaskellModulePath -- ^ Current module path -> HCE.PackageId -- ^ Current package id -> HCE.ComponentId -- ^ Current build component id -> (T.Text, HCE.SourceCodePreprocessing) -- ^ Source code -> (HCE.ModuleInfo, ModuleDependencies, [TypeError]) -createModuleInfo (fileMap, defSiteMap, moduleNameMap) (flags, unitState, typecheckedModule, homePackageTable, externalPackageState, modSum) modulePath currentPackageId compId (originalSourceCode, sourceCodePreprocessing) = - let globalRdrEnv = tcg_rdr_env . fst . tm_internals_ $ typecheckedModule +createModuleInfo (fileMap, defSiteMap, moduleNameMap) (flags, unitState, typecheckedModule, homePackageTable, externalPackageState, modSum) modulePath currentPackageId compId (originalSourceCode, sourceCodePreprocessing) + = let + globalRdrEnv = tcg_rdr_env . fst . tm_internals_ $ typecheckedModule modInfo = moduleInfo typecheckedModule (Just (hsGroup, _, _, _)) = renamedSource typecheckedModule exportedNamesSet = S.fromList $ modInfoExportsWithSelectors modInfo -------------------------------------------------------------------------------- -- Preprocessed source -------------------------------------------------------------------------------- - (transformation, sourceCode') = - prepareSourceCode - sourceCodePreprocessing - originalSourceCode - modSum - modulePath - includedFiles = HM.keys $ HCE.fileIndex transformation + (transformation, sourceCode') = prepareSourceCode + sourceCodePreprocessing + originalSourceCode + modSum + modulePath + includedFiles = HM.keys $ HCE.fileIndex transformation -------------------------------------------------------------------------------- -- Type environment -------------------------------------------------------------------------------- - (tcGblEnv, _) = tm_internals_ typecheckedModule + (tcGblEnv, _) = tm_internals_ typecheckedModule currentModuleTyThings = typeEnvElts $ tcg_type_env tcGblEnv - homePackageTyThings = - concatMap (typeEnvElts . md_types . hm_details) $ -#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) - eltsUDFM homePackageTable -#else - eltsUFM homePackageTable -#endif + homePackageTyThings = concatMap (typeEnvElts . md_types . hm_details) + $ eltsUDFM homePackageTable externalPackagesTyThings = typeEnvElts $ eps_PTE externalPackageState - typeEnv = - mkTypeEnv - (currentModuleTyThings ++ - homePackageTyThings ++ externalPackagesTyThings) + typeEnv = mkTypeEnv + ( currentModuleTyThings + ++ homePackageTyThings + ++ externalPackagesTyThings + ) -------------------------------------------------------------------------------- -- Exported entities -------------------------------------------------------------------------------- - dataFamTyCons = - mapMaybe - (\case - ATyCon tc - | isFamInstTyCon tc -> Just $ tyConName tc - _ -> Nothing) - currentModuleTyThings - (defSites, allNames) = - createDefinitionSiteMap - flags - unitState - currentPackageId - compId - defSiteMap - fileMap - globalRdrEnv - transformation - modInfo - dataFamTyCons - hsGroup + dataFamTyCons = mapMaybe + (\case + ATyCon tc | isFamInstTyCon tc -> Just $ tyConName tc + _ -> Nothing + ) + currentModuleTyThings + (defSites, allNames) = createDefinitionSiteMap flags + unitState + currentPackageId + compId + defSiteMap + fileMap + globalRdrEnv + transformation + modInfo + dataFamTyCons + hsGroup -------------------------------------------------------------------------------- -- Instance environment -------------------------------------------------------------------------------- - homeInstEnv = tcg_inst_env tcGblEnv + homeInstEnv = tcg_inst_env tcGblEnv visOrphanModules = tcVisibleOrphanMods tcGblEnv - packageInstEnv = eps_inst_env externalPackageState - instEnv = InstEnvs packageInstEnv homeInstEnv visOrphanModules + packageInstEnv = eps_inst_env externalPackageState + instEnv = InstEnvs packageInstEnv homeInstEnv visOrphanModules -------------------------------------------------------------------------------- - declarations = - createDeclarations flags hsGroup typeEnv exportedNamesSet transformation - environment = - Environment - { envDynFlags = flags - , envUnitState = unitState - , envInstEnv = instEnv - , envTypeEnv = typeEnv - , envTransformation = transformation - , envCurrentModuleDefSites = defSites - , envFileMap = fileMap - , envDefSiteMap = defSiteMap - , envModuleNameMap = moduleNameMap - , envPackageId = currentPackageId - , envComponentId = compId - , envExportedNames = exportedNamesSet - } - externalIds = - L.foldl' - (\acc name -> - maybe - acc - (\id -> (HCE.ExternalIdentifierInfo $ mkIdentifierInfo environment id (Just name)) : acc) - (lookupIdInTypeEnv typeEnv name)) - [] - allNames + declarations = createDeclarations flags + hsGroup + typeEnv + exportedNamesSet + transformation + environment = Environment { envDynFlags = flags + , envUnitState = unitState + , envInstEnv = instEnv + , envTypeEnv = typeEnv + , envTransformation = transformation + , envCurrentModuleDefSites = defSites + , envFileMap = fileMap + , envDefSiteMap = defSiteMap + , envModuleNameMap = moduleNameMap + , envPackageId = currentPackageId + , envComponentId = compId + , envExportedNames = exportedNamesSet + } + externalIds = L.foldl' + (\acc name -> maybe + acc + (\id -> + ( HCE.ExternalIdentifierInfo + $ mkIdentifierInfo environment id (Just name) + ) + : acc + ) + (lookupIdInTypeEnv typeEnv name) + ) + [] + allNames currentModuleName = (\(Module _ name) -> - HCE.HaskellModuleName . T.pack . moduleNameString $ name) . - ms_mod $ - modSum + HCE.HaskellModuleName . T.pack . moduleNameString $ name + ) + . ms_mod + $ modSum SourceInfo {..} = foldAST environment typecheckedModule - in (tidyInternalIds HCE.ModuleInfo - { id = modulePath - , transformation = transformation - , name = currentModuleName - , declarations = declarations - , exprInfoMap = sourceInfoExprMap - , idInfoMap = sourceInfoIdMap - , idOccMap = sourceInfoIdOccMap - , definitionSiteMap = defSites - , source = V.fromList . T.splitOn "\n" $ sourceCode' - , externalIds = externalIds - } + in + ( tidyInternalIds HCE.ModuleInfo + { id = modulePath + , transformation = transformation + , name = currentModuleName + , declarations = declarations + , exprInfoMap = sourceInfoExprMap + , idInfoMap = sourceInfoIdMap + , idOccMap = sourceInfoIdOccMap + , definitionSiteMap = defSites + , source = V.fromList . T.splitOn "\n" $ sourceCode' + , externalIds = externalIds + } , if not $ isHsBoot modulePath - then (HM.union - (HM.fromList . - (( HCE.HaskellFilePath $ HCE.getHaskellModulePath modulePath - , modulePath) :) . - map (, modulePath) $ - includedFiles) - fileMap - , HM.union (HM.singleton modulePath defSites) defSiteMap - , HM.insertWith HM.union currentModuleName - (HM.singleton compId modulePath) moduleNameMap) - else (fileMap, defSiteMap, moduleNameMap) - , sourceInfoTypeErrors) + then + ( HM.union + ( HM.fromList + . (( HCE.HaskellFilePath $ HCE.getHaskellModulePath modulePath + , modulePath + ) : + ) + . map (, modulePath) + $ includedFiles + ) + fileMap + , HM.union (HM.singleton modulePath defSites) defSiteMap + , HM.insertWith HM.union + currentModuleName + (HM.singleton compId modulePath) + moduleNameMap + ) + else (fileMap, defSiteMap, moduleNameMap) + , sourceInfoTypeErrors + ) data SourceInfo = SourceInfo - { sourceInfoExprMap :: HCE.ExpressionInfoMap - , sourceInfoIdMap :: HCE.IdentifierInfoMap - , sourceInfoIdOccMap :: HCE.IdentifierOccurrenceMap + { sourceInfoExprMap :: HCE.ExpressionInfoMap + , sourceInfoIdMap :: HCE.IdentifierInfoMap + , sourceInfoIdOccMap :: HCE.IdentifierOccurrenceMap , sourceInfoTypeErrors :: [TypeError] - } deriving (Show, Eq) + } + deriving (Show, Eq) tidyInternalIds :: HCE.ModuleInfo -> HCE.ModuleInfo tidyInternalIds modInfo = evalState (U.transformBiM tidy modInfo) (HM.empty, 0) - where - tidy :: - HCE.InternalId -> State (HM.HashMap T.Text T.Text, Int) HCE.InternalId - tidy (HCE.InternalId text) = do - (hmap, number) <- get - case HM.lookup text hmap of - Just val -> return $ HCE.InternalId val - Nothing -> do - let nextInternalId = T.pack . show $ number - put (HM.insert text nextInternalId hmap, number + 1) - return $ HCE.InternalId nextInternalId + where + tidy + :: HCE.InternalId -> State (HM.HashMap T.Text T.Text, Int) HCE.InternalId + tidy (HCE.InternalId text) = do + (hmap, number) <- get + case HM.lookup text hmap of + Just val -> return $ HCE.InternalId val + Nothing -> do + let nextInternalId = T.pack . show $ number + put (HM.insert text nextInternalId hmap, number + 1) + return $ HCE.InternalId nextInternalId -prepareSourceCode :: - HCE.SourceCodePreprocessing +prepareSourceCode + :: HCE.SourceCodePreprocessing -> T.Text -> ModSummary -> HCE.HaskellModulePath -> (HCE.SourceCodeTransformation, T.Text) -prepareSourceCode sourceCodePreprocessing originalSourceCode modSum modulePath = - let sourceCodeAfterPreprocessing = - case TE.decodeUtf8' $ - maybe - (error "ms_hspp_buf is Nothing") - stringBufferToByteString - (ms_hspp_buf modSum) of - Right text -> T.replace "\t" " " text - Left err -> - error $ - "decodeUtf8' : " ++ show err ++ " , file : " ++ show modulePath - in case sourceCodePreprocessing of - HCE.BeforePreprocessing -> - let sourceCodeLines = T.splitOn "\n" originalSourceCode - in ( HCE.SourceCodeTransformation - (length sourceCodeLines) - modulePath - S.empty - HM.empty - , originalSourceCode) - HCE.AfterPreprocessing -> - createSourceCodeTransformation +prepareSourceCode sourceCodePreprocessing originalSourceCode modSum modulePath + = let sourceCodeAfterPreprocessing = + case + TE.decodeUtf8' $ maybe (error "ms_hspp_buf is Nothing") + stringBufferToByteString + (ms_hspp_buf modSum) + of + Right text -> T.replace "\t" " " text + Left err -> + error + $ "decodeUtf8' : " + ++ show err + ++ " , file : " + ++ show modulePath + in case sourceCodePreprocessing of + HCE.BeforePreprocessing -> + let sourceCodeLines = T.splitOn "\n" originalSourceCode + in ( HCE.SourceCodeTransformation (length sourceCodeLines) + modulePath + S.empty + HM.empty + , originalSourceCode + ) + HCE.AfterPreprocessing -> createSourceCodeTransformation modulePath originalSourceCode sourceCodeAfterPreprocessing -createDefinitionSiteMap :: - DynFlags +createDefinitionSiteMap + :: DynFlags -> UnitState -> HCE.PackageId -> HCE.ComponentId @@ -323,137 +360,143 @@ 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 unitState currentPackageId compId defSiteMap fileMap globalRdrEnv transformation modInfo dataFamTyCons hsGroup = - let +createDefinitionSiteMap flags unitState currentPackageId compId defSiteMap fileMap globalRdrEnv transformation modInfo dataFamTyCons hsGroup + = let allDecls :: [LHsDecl GhcRn] allDecls = sortLocatedA . ungroup $ hsGroup (instanceDeclsWithDocs, valueAndTypeDeclsWithDocs) = L.partition - (\(L _ decl, _) -> - case decl of - InstD {} -> True - _ -> False) $ - collectDocs allDecls + (\(L _ decl, _) -> case decl of + InstD{} -> True + _ -> False + ) + $ collectDocs allDecls -------------------------------------------------------------------------------- -- Instances -------------------------------------------------------------------------------- -- No type instances or data instances here for now instanceDocMap :: M.Map SrcSpan [HsDocString] instanceDocMap = - M.fromList . - mapMaybe - (\(L _n decl, docs) -> - case decl of -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) - InstD _ (ClsInstD _ inst) -> Just (clsInstDeclSrcSpan inst, docs) -#else - InstD (ClsInstD inst) -> Just (clsInstDeclSrcSpan inst, docs) -#endif - _ -> Nothing) $ - instanceDeclsWithDocs + M.fromList + . mapMaybe + (\(L _n decl, docs) -> case decl of + InstD _ (ClsInstD _ inst) -> + Just (clsInstDeclSrcSpan inst, docs) + _ -> Nothing + ) + $ instanceDeclsWithDocs nameLocation :: Maybe SrcSpan -> Name -> HCE.LocationInfo - nameLocation = - nameLocationInfo - unitState - currentPackageId - compId - transformation - fileMap - defSiteMap - Nothing + nameLocation = nameLocationInfo unitState + currentPackageId + compId + transformation + fileMap + defSiteMap + Nothing docHToHtml :: DocH (ModuleName, OccName) Name -> HCE.HTML - docHToHtml = - docWithNamesToHtml - flags - unitState - currentPackageId - compId - transformation - fileMap - defSiteMap + docHToHtml = docWithNamesToHtml flags + unitState + currentPackageId + compId + transformation + fileMap + defSiteMap instancesWithDocumentation = - HM.fromList . - map - (\clsInst -> - ( instanceToText flags clsInst - , let location = - nameLocation Nothing (varName . is_dfun $ clsInst) - in case M.lookup (getSrcSpan clsInst) instanceDocMap of - Just hsDocString -> - HCE.DefinitionSite - location - (Just . docHToHtml . hsDocsToDocH flags globalRdrEnv $ - hsDocString) - Nothing -> HCE.DefinitionSite location Nothing)) $ - modInfoInstances modInfo -- all instances (including derived) + HM.fromList + . map + (\clsInst -> + ( instanceToText flags clsInst + , let location = + nameLocation Nothing (varName . is_dfun $ clsInst) + in case M.lookup (getSrcSpan clsInst) instanceDocMap of + Just hsDocString -> HCE.DefinitionSite + location + ( Just + . docHToHtml + . hsDocsToDocH flags globalRdrEnv + $ hsDocString + ) + Nothing -> HCE.DefinitionSite location Nothing + ) + ) + $ modInfoInstances modInfo -- all instances (including derived) -------------------------------------------------------------------------------- -- Values and types -------------------------------------------------------------------------------- - mainDeclNamesWithDocumentation = - concatMap - (\(dec@(L _ decl), docs) -> - map (, docs, getLocA dec) $ getMainDeclBinder decl) - valueAndTypeDeclsWithDocs + mainDeclNamesWithDocumentation = concatMap + (\(dec@(L _ decl), docs) -> + map (, docs, getLocA dec) $ getMainDeclBinder decl + ) + valueAndTypeDeclsWithDocs dataFamTyConsWithoutDocs = map (\name -> (name, [], nameSrcSpan name)) dataFamTyCons allNamesWithDocumentation = - mainDeclNamesWithDocumentation ++ - subordinateNamesWithDocs allDecls ++ - dataFamTyConsWithoutDocs - (valuesWithDocumentation, typesWithDocumentation) = - L.partition - (\(name, _doc, _srcSpan) -> - case occNameNameSpace . nameOccName $ name of - HCE.VarName -> True - HCE.DataName -> True - _ -> False) - allNamesWithDocumentation - toHashMap :: - [(Name, [HsDocString], SrcSpan)] + mainDeclNamesWithDocumentation + ++ subordinateNamesWithDocs allDecls + ++ dataFamTyConsWithoutDocs + (valuesWithDocumentation, typesWithDocumentation) = L.partition + (\(name, _doc, _srcSpan) -> + case occNameNameSpace . nameOccName $ name of + HCE.VarName -> True + HCE.DataName -> True + _ -> False + ) + allNamesWithDocumentation + toHashMap + :: [(Name, [HsDocString], SrcSpan)] -> HM.HashMap HCE.OccName HCE.DefinitionSite toHashMap = HM.fromListWith - (\(HCE.DefinitionSite loc newDoc) (HCE.DefinitionSite _ oldDoc) -> - (HCE.DefinitionSite loc $ mappend newDoc oldDoc)) . - map - (\(name, docs, srcSpan) -> - let location = nameLocation (Just srcSpan) name - htmlDoc = - if not . null $ docs - then Just . docHToHtml . hsDocsToDocH flags globalRdrEnv $ - docs - else Nothing - in (HCE.OccName $ toText flags name, HCE.DefinitionSite location htmlDoc)) - -------------------------------------------------------------------------------- - in ( HCE.DefinitionSiteMap - { HCE.values = toHashMap valuesWithDocumentation - , HCE.types = - toHashMap $ typesWithDocumentation ++ dataFamTyConsWithoutDocs - , HCE.instances = instancesWithDocumentation - } - , map (\(n, _, _) -> n) allNamesWithDocumentation) + (\(HCE.DefinitionSite loc newDoc) (HCE.DefinitionSite _ oldDoc) -> + (HCE.DefinitionSite loc $ mappend newDoc oldDoc) + ) + . map + (\(name, docs, srcSpan) -> + let location = nameLocation (Just srcSpan) name + htmlDoc = if not . null $ docs + then + Just + . docHToHtml + . hsDocsToDocH flags globalRdrEnv + $ docs + else Nothing + in ( HCE.OccName $ toText flags name + , HCE.DefinitionSite location htmlDoc + ) + ) + -------------------------------------------------------------------------------- + in + ( HCE.DefinitionSiteMap + { HCE.values = toHashMap valuesWithDocumentation + , HCE.types = toHashMap + $ typesWithDocumentation + ++ dataFamTyConsWithoutDocs + , HCE.instances = instancesWithDocumentation + } + , map (\(n, _, _) -> n) allNamesWithDocumentation + ) -occNameToHtml :: - DynFlags +occNameToHtml + :: DynFlags -> HCE.PackageId -> HCE.ComponentId -> (ModuleName, OccName) -> H.Html occNameToHtml flags packageId compId (modName, occName) = let location = - H.textValue . toStrict . encodeToLazyText . Aeson.toJSON $ - occNameLocationInfo flags packageId compId (modName, occName) - in (H.span H.! H.dataAttribute "location" location) H.! A.class_ "link" $ - H.toHtml (toText flags occName) + H.textValue + . toStrict + . encodeToLazyText + . Aeson.toJSON + $ occNameLocationInfo flags packageId compId (modName, occName) + in (H.span H.! H.dataAttribute "location" location) + H.! A.class_ "link" + $ H.toHtml (toText flags occName) -nameToHtml :: - UnitState +nameToHtml + :: UnitState -> HCE.PackageId -> HCE.ComponentId -> HCE.SourceCodeTransformation @@ -463,22 +506,26 @@ nameToHtml :: -> H.Html nameToHtml unitState packageId compId transformation files defSiteMap name = let location = - H.textValue . toStrict . encodeToLazyText . Aeson.toJSON $ - nameLocationInfo - unitState - packageId - compId - transformation - files - defSiteMap - Nothing - Nothing - name - in H.span H.! H.dataAttribute "location" location H.! A.class_ "link" $ - H.toHtml (nameToText name) + H.textValue + . toStrict + . encodeToLazyText + . Aeson.toJSON + $ nameLocationInfo unitState + packageId + compId + transformation + files + defSiteMap + Nothing + Nothing + name + in H.span + H.! H.dataAttribute "location" location + H.! A.class_ "link" + $ H.toHtml (nameToText name) -docWithNamesToHtml :: - DynFlags +docWithNamesToHtml + :: DynFlags -> UnitState -> HCE.PackageId -> HCE.ComponentId @@ -487,18 +534,14 @@ docWithNamesToHtml :: -> HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap -> DocH (ModuleName, OccName) Name -> HCE.HTML -docWithNamesToHtml flags unitState packageId compId transformation fileMap defSiteMap = - HCE.docToHtml +docWithNamesToHtml flags unitState packageId compId transformation fileMap defSiteMap + = HCE.docToHtml (occNameToHtml flags packageId compId) (nameToHtml unitState packageId compId transformation fileMap defSiteMap) -createDeclarations :: - DynFlags -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +createDeclarations + :: DynFlags -> HsGroup GhcRn -#else - -> HsGroup Name -#endif -> TypeEnv -> S.Set Name -> HCE.SourceCodeTransformation @@ -507,227 +550,211 @@ createDeclarations flags hsGroup typeEnv exportedSet transformation = let lineNumber :: SrcSpan -> Int lineNumber srcSpan = case srcSpanToLineAndColNumbers transformation srcSpan of - Just (_file,(lineNum, _), (_, _)) -> lineNum - Nothing -> 1 + Just (_file, (lineNum, _), (_, _)) -> lineNum + Nothing -> 1 nameType :: Name -> Maybe HCE.Type - nameType n = - case lookupIdInTypeEnv typeEnv n of - Just i -> Just . mkType flags . varType $ i - Nothing -> Nothing + nameType n = case lookupIdInTypeEnv typeEnv n of + Just i -> Just . mkType flags . varType $ i + Nothing -> Nothing -- | Top-level functions -------------------------------------------------------------------------------- valToDeclarations :: LHsBindLR GhcRn GhcRn -> [HCE.Declaration] valToDeclarations lb@(L _ bind) = map - (\name -> - HCE.Declaration - HCE.ValD - (toText flags name) - (nameType name) - (S.member name exportedSet) - (lineNumber (getLocA lb))) $ - collectHsBindBinders CollNoDictBinders bind + (\name -> HCE.Declaration HCE.ValD + (toText flags name) + (nameType name) + (S.member name exportedSet) + (lineNumber (getLocA lb)) + ) + $ collectHsBindBinders CollNoDictBinders bind vals = concatMap valToDeclarations $ hsGroupVals hsGroup -- | Data, newtype, type, type family, data family or class declaration -------------------------------------------------------------------------------- tyClToDeclaration :: LTyClDecl GhcRn -> HCE.Declaration - tyClToDeclaration lt@(L _ tyClDecl) = - HCE.Declaration - HCE.TyClD - (T.append (tyClDeclPrefix tyClDecl) (toText flags $ tcdName tyClDecl)) - (nameType $ tcdName tyClDecl) - (S.member (unLoc $ tyClDeclLName tyClDecl) exportedSet) - (lineNumber (getLocA lt)) + tyClToDeclaration lt@(L _ tyClDecl) = HCE.Declaration + HCE.TyClD + (T.append (tyClDeclPrefix tyClDecl) (toText flags $ tcdName tyClDecl)) + (nameType $ tcdName tyClDecl) + (S.member (unLoc $ tyClDeclLName tyClDecl) exportedSet) + (lineNumber (getLocA lt)) tyclds = - map tyClToDeclaration . - filter (isGoodSrcSpan . getLocA) . concatMap group_tyclds . hs_tyclds $ - hsGroup + map tyClToDeclaration + . filter (isGoodSrcSpan . getLocA) + . concatMap group_tyclds + . hs_tyclds + $ hsGroup -- | Instances -------------------------------------------------------------------------------- -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) instToDeclaration :: LInstDecl GhcRn -> HCE.Declaration -#endif - instToDeclaration li@(L _ inst) = - HCE.Declaration - HCE.InstD - (instanceDeclToText flags inst) - Nothing - True - (lineNumber (getLocA li)) + instToDeclaration li@(L _ inst) = HCE.Declaration + HCE.InstD + (instanceDeclToText flags inst) + Nothing + True + (lineNumber (getLocA li)) insts = - map instToDeclaration . filter (isGoodSrcSpan . getLocA) . hsGroupInstDecls $ - hsGroup + map instToDeclaration + . filter (isGoodSrcSpan . getLocA) + . hsGroupInstDecls + $ hsGroup -- | Foreign functions -------------------------------------------------------------------------------- foreignFunToDeclaration :: LForeignDecl GhcRn -> HCE.Declaration foreignFunToDeclaration lf@(L _ fd) = let name = unLoc $ fd_name fd - in HCE.Declaration - HCE.ForD - (toText flags name) - (nameType name) - True - (lineNumber (getLocA lf)) + in HCE.Declaration HCE.ForD + (toText flags name) + (nameType name) + True + (lineNumber (getLocA lf)) fords = map foreignFunToDeclaration $ hs_fords hsGroup -------------------------------------------------------------------------------- - in L.sortOn HCE.lineNumber $ vals ++ tyclds ++ insts ++ fords + in L.sortOn HCE.lineNumber $ vals ++ tyclds ++ insts ++ fords foldAST :: Environment -> TypecheckedModule -> SourceInfo foldAST environment typecheckedModule = - let (Just renamed@(_, importDecls, mbExported, _)) = - renamedSource typecheckedModule - emptyASTState = - ASTState IVM.empty IM.empty M.empty emptyTidyEnv Nothing environment [] - ASTState {..} = - execState - (foldTypecheckedSource $ tm_typechecked_source typecheckedModule) - emptyASTState - -- A few things that are not in the output of the typechecker: - -- - the export list - -- - the imports - -- - type signatures - -- - type/data/newtype declarations - -- - class declarations + let + (Just renamed@(_, importDecls, mbExported, _)) = + renamedSource typecheckedModule + emptyASTState = + ASTState IVM.empty IM.empty M.empty emptyTidyEnv Nothing environment [] + ASTState {..} = execState + (foldTypecheckedSource $ tm_typechecked_source typecheckedModule) + emptyASTState + -- A few things that are not in the output of the typechecker: + -- - the export list + -- - the imports + -- - type signatures + -- - type/data/newtype declarations + -- - class declarations - -- Both typechecked source and renamed source are used to populate - -- 'IdentifierInfoMap' and 'IdentifierOccurrenceMap' - (idInfoMap, idOccMap) = - L.foldl' - (addIdentifierToMaps environment astStateIdSrcSpanMap) - (HM.empty, astStateIdOccMap) - (namesFromRenamedSource renamed) - unitState = envUnitState environment - packageId = envPackageId environment - compId = envComponentId environment - importedModules = - map - ((\lm@(L _ modName) -> + -- Both typechecked source and renamed source are used to populate + -- 'IdentifierInfoMap' and 'IdentifierOccurrenceMap' + (idInfoMap, idOccMap) = L.foldl' + (addIdentifierToMaps environment astStateIdSrcSpanMap) + (HM.empty, astStateIdOccMap) + (namesFromRenamedSource renamed) + unitState = envUnitState environment + packageId = envPackageId environment + compId = envComponentId environment + importedModules = + map + ( (\lm@(L _ modName) -> ( modName , getLocA lm - , moduleLocationInfo - unitState - (envModuleNameMap environment) - packageId - compId - modName)) . - ideclName . unLoc) . - filter (not . ideclImplicit . unLoc) $ - importDecls - exportedModules = - case mbExported of - Just lieNames -> - mapMaybe - (\(li@(L _ ie),_) -> - case ie of - IEModuleContents _ (L _ modName) -> - Just - ( modName - , getLocA li - , moduleLocationInfo - unitState - (envModuleNameMap environment) - packageId - compId - modName) - _ -> Nothing) - lieNames - Nothing -> [] - addImportedAndExportedModulesToIdOccMap :: - HCE.IdentifierOccurrenceMap -> HCE.IdentifierOccurrenceMap - addImportedAndExportedModulesToIdOccMap = - IM.map (L.sortOn fst) . - addModules - (envTransformation environment) - (importedModules ++ exportedModules) - in SourceInfo - { sourceInfoExprMap = astStateExprInfoMap - , sourceInfoIdMap = idInfoMap - , sourceInfoIdOccMap = addImportedAndExportedModulesToIdOccMap idOccMap - , sourceInfoTypeErrors = astStateTypeErrors - } + , moduleLocationInfo unitState + (envModuleNameMap environment) + packageId + compId + modName + ) + ) + . ideclName + . unLoc + ) + . filter (not . ideclImplicit . unLoc) + $ importDecls + exportedModules = case mbExported of + Just lieNames -> mapMaybe + (\(li@(L _ ie), _) -> case ie of + IEModuleContents _ (L _ modName) -> Just + ( modName + , getLocA li + , moduleLocationInfo unitState + (envModuleNameMap environment) + packageId + compId + modName + ) + _ -> Nothing + ) + lieNames + Nothing -> [] + addImportedAndExportedModulesToIdOccMap + :: HCE.IdentifierOccurrenceMap -> HCE.IdentifierOccurrenceMap + addImportedAndExportedModulesToIdOccMap = + IM.map (L.sortOn fst) . addModules (envTransformation environment) + (importedModules ++ exportedModules) + in + SourceInfo + { sourceInfoExprMap = astStateExprInfoMap + , sourceInfoIdMap = idInfoMap + , sourceInfoIdOccMap = addImportedAndExportedModulesToIdOccMap idOccMap + , sourceInfoTypeErrors = astStateTypeErrors + } -- | Updates 'IdentifierOccurrenceMap' and 'IdentifierInfoMap' using information -- from typechecked source and renamed source -addIdentifierToMaps :: - Environment +addIdentifierToMaps + :: Environment -> M.Map SrcSpan (Id, Maybe (Type, [Type])) -> (HCE.IdentifierInfoMap, HCE.IdentifierOccurrenceMap) -> NameOccurrence -> (HCE.IdentifierInfoMap, HCE.IdentifierOccurrenceMap) addIdentifierToMaps environment idSrcSpanMap idMaps@(idInfoMap, idOccMap) nameOcc - | isGoodSrcSpan (getLoc $ locatedName nameOcc) && - isOneLineSpan (getLoc $ locatedName nameOcc) + | isGoodSrcSpan (getLoc $ locatedName nameOcc) + && isOneLineSpan (getLoc $ locatedName nameOcc) , Just (_, (lineNumber, startCol), (_, endCol)) <- - srcSpanToLineAndColNumbers (envTransformation environment) . - getLoc . locatedName $ - nameOcc = - case nameOcc of - TyLitOccurrence {kind = kind} -> - addNameToMaps - environment - idMaps - (Just kind) - Nothing - (description nameOcc) - lineNumber - startCol - endCol - NameOccurrence {isBinder = isBinder} -> - case lookupIdByNameOccurrence environment idSrcSpanMap nameOcc of - Just (identifier, mbTypes) -> - let name = - fromMaybe - (varName identifier) - (unLoc $ locatedName nameOcc) - identifierType = varType identifier - identifierTypeExpanded = expandTypeSynonyms identifierType - tyConsAndTyVars = - map - (, Nothing) - (tyConsOfType identifierType ++ - tyVarsOfType identifierType ++ - tyConsOfType identifierTypeExpanded ++ - tyVarsOfType identifierTypeExpanded ++ - maybe [] (tyConsOfType . fst) mbTypes ++ - maybe [] (tyVarsOfType . fst) mbTypes) - idInfoMap' = - updateIdMap - environment - ((identifier, unLoc $ locatedName nameOcc) : tyConsAndTyVars) - idInfoMap - idOcc = - mkIdentifierOccurrence - environment - identifier - name - mbTypes - isBinder - (description nameOcc) - idOccMap' = - IM.insertWith - removeOverlappingInterval - lineNumber - [((startCol, endCol), idOcc)] - idOccMap - in (idInfoMap', idOccMap') - Nothing -- type variable or an internal identifier in a pattern synonym - -> - case unLoc $ locatedName nameOcc of - Just name -> - addNameToMaps - environment - idMaps - Nothing - (Just name) - (description nameOcc) - lineNumber - startCol - endCol - Nothing -> idMaps + srcSpanToLineAndColNumbers (envTransformation environment) + . getLoc + . locatedName + $ nameOcc + = case nameOcc of + TyLitOccurrence { kind = kind } -> addNameToMaps environment + idMaps + (Just kind) + Nothing + (description nameOcc) + lineNumber + startCol + endCol + NameOccurrence { isBinder = isBinder } -> + case lookupIdByNameOccurrence environment idSrcSpanMap nameOcc of + Just (identifier, mbTypes) -> + let name = + fromMaybe (varName identifier) (unLoc $ locatedName nameOcc) + identifierType = varType identifier + identifierTypeExpanded = expandTypeSynonyms identifierType + tyConsAndTyVars = map + (, Nothing) + ( tyConsOfType identifierType + ++ tyVarsOfType identifierType + ++ tyConsOfType identifierTypeExpanded + ++ tyVarsOfType identifierTypeExpanded + ++ maybe [] (tyConsOfType . fst) mbTypes + ++ maybe [] (tyVarsOfType . fst) mbTypes + ) + idInfoMap' = updateIdMap + environment + ((identifier, unLoc $ locatedName nameOcc) : tyConsAndTyVars) + idInfoMap + idOcc = mkIdentifierOccurrence environment + identifier + name + mbTypes + isBinder + (description nameOcc) + idOccMap' = IM.insertWith removeOverlappingInterval + lineNumber + [((startCol, endCol), idOcc)] + idOccMap + in (idInfoMap', idOccMap') + -- type variable or an internal identifier in a pattern synonym + Nothing -> case unLoc $ locatedName nameOcc of + Just name -> addNameToMaps environment + idMaps + Nothing + (Just name) + (description nameOcc) + lineNumber + startCol + endCol + Nothing -> idMaps addIdentifierToMaps _ _ idMaps _ = idMaps -addNameToMaps :: - Environment +addNameToMaps + :: Environment -> (HCE.IdentifierInfoMap, HCE.IdentifierOccurrenceMap) -> Maybe Type -> Maybe Name @@ -735,114 +762,110 @@ addNameToMaps :: -> Int -> Int -> Int - -> (HCE.IdentifierInfoMap, HCE.IdentifierOccurrenceMap) -addNameToMaps environment (idInfoMap, idOccMap) mbKind mbName descr lineNumber colStart colEnd = - let flags = envDynFlags environment - idInfoMap' = - maybe + -> ( HCE.IdentifierInfoMap + , HCE.IdentifierOccurrenceMap + ) +addNameToMaps environment (idInfoMap, idOccMap) mbKind mbName descr lineNumber colStart colEnd + = let flags = envDynFlags environment + idInfoMap' = maybe idInfoMap - (\kind -> - updateIdMap - environment - (map (, Nothing) $ tyConsOfType kind ++ tyVarsOfType kind) - idInfoMap) + (\kind -> updateIdMap + environment + (map (, Nothing) $ tyConsOfType kind ++ tyVarsOfType kind) + idInfoMap + ) mbKind - idOcc = - HCE.IdentifierOccurrence - { internalId = fmap (HCE.InternalId . nameKey) mbName - , internalIdFromRenamedSource = - HCE.InternalId . T.pack . show . getKey . nameUnique <$> mbName - , isBinder = False - , instanceResolution = Nothing - , idOccType = mkType flags <$> mbKind - , typeArguments = Nothing - , description = descr - , sort = - maybe - HCE.TypeId - (\name -> - case occNameNameSpace . nameOccName $ name of - HCE.VarName -> HCE.ValueId - HCE.DataName -> HCE.ValueId - _ -> HCE.TypeId) - mbName + idOcc = HCE.IdentifierOccurrence + { internalId = fmap (HCE.InternalId . nameKey) mbName + , internalIdFromRenamedSource = HCE.InternalId + . T.pack + . show + . getKey + . nameUnique + <$> mbName + , isBinder = False + , instanceResolution = Nothing + , idOccType = mkType flags <$> mbKind + , typeArguments = Nothing + , description = descr + , sort = maybe + HCE.TypeId + (\name -> case occNameNameSpace . nameOccName $ name of + HCE.VarName -> HCE.ValueId + HCE.DataName -> HCE.ValueId + _ -> HCE.TypeId + ) + mbName } - idOccMap' = - IM.insertWith - removeOverlappingInterval - lineNumber - [((colStart, colEnd), idOcc)] - idOccMap - in (idInfoMap', idOccMap') + idOccMap' = IM.insertWith removeOverlappingInterval + lineNumber + [((colStart, colEnd), idOcc)] + idOccMap + in (idInfoMap', idOccMap') -lookupIdByNameOccurrence :: - Environment +lookupIdByNameOccurrence + :: Environment -> M.Map SrcSpan (Id, Maybe (Type, [Type])) -> NameOccurrence -> Maybe (Id, Maybe (Type, [Type])) -lookupIdByNameOccurrence environment idSrcSpanMap (NameOccurrence (L span mbName) _ _) = - case M.lookup span idSrcSpanMap of +lookupIdByNameOccurrence environment idSrcSpanMap (NameOccurrence (L span mbName) _ _) + = case M.lookup span idSrcSpanMap of Just (identifier, mbTypes) -> Just (identifier, mbTypes) - Nothing -> - case mbName of - Just name -> - case M.lookup (nameSrcSpan name) idSrcSpanMap of - -- LHS of a Match - Just (identifier, mbTypes) -> Just (identifier, mbTypes) - Nothing -> - -- Things that are not in the typechecked source - case lookupIdInTypeEnv (envTypeEnv environment) name of - Just t -> Just (t, Nothing) - Nothing -> Nothing - Nothing -> Nothing -lookupIdByNameOccurrence _ _ TyLitOccurrence {} = Nothing + Nothing -> case mbName of + Just name -> case M.lookup (nameSrcSpan name) idSrcSpanMap of + -- LHS of a Match + Just (identifier, mbTypes) -> Just (identifier, mbTypes) + Nothing -> + -- Things that are not in the typechecked source + case lookupIdInTypeEnv (envTypeEnv environment) name of + Just t -> Just (t, Nothing) + Nothing -> Nothing + Nothing -> Nothing +lookupIdByNameOccurrence _ _ TyLitOccurrence{} = Nothing -updateIdMap :: - Environment +updateIdMap + :: Environment -> [(Id, Maybe Name)] -> HCE.IdentifierInfoMap -> HCE.IdentifierInfoMap updateIdMap environment ids identifiersMap = let flags = envDynFlags environment - update :: - HCE.IdentifierInfoMap -> (Id, Maybe Name) -> HCE.IdentifierInfoMap + update + :: HCE.IdentifierInfoMap -> (Id, Maybe Name) -> HCE.IdentifierInfoMap update idMap (identifier, mbName) = let info = mkIdentifierInfo environment identifier mbName - in HM.insertWith - (flip const) - (HCE.InternalId $ identifierKey flags identifier) - info - idMap - in L.foldl' update identifiersMap ids + in HM.insertWith (flip const) + (HCE.InternalId $ identifierKey flags identifier) + info + idMap + in L.foldl' update identifiersMap ids -addModules :: - HCE.SourceCodeTransformation +addModules + :: HCE.SourceCodeTransformation -> [(ModuleName, SrcSpan, HCE.LocationInfo)] -> HCE.IdentifierOccurrenceMap -> HCE.IdentifierOccurrenceMap addModules transformation modules idMap = - let update :: - IM.IntMap [((Int, Int), HCE.IdentifierOccurrence)] + let update + :: IM.IntMap [((Int, Int), HCE.IdentifierOccurrence)] -> (a, SrcSpan, HCE.LocationInfo) -> IM.IntMap [((Int, Int), HCE.IdentifierOccurrence)] update idOccMap (_modInfo, span, locInfo) - | Just (_file,(lineNumber, colStart), (_, colEnd)) <- - srcSpanToLineAndColNumbers transformation span = - let idOcc = - HCE.IdentifierOccurrence - { internalId = Nothing - , internalIdFromRenamedSource = Nothing - , isBinder = False - , instanceResolution = Nothing - , idOccType = Nothing - , typeArguments = Nothing - , description = "ImportDecl" - , sort = HCE.ModuleId locInfo - } - in IM.insertWith - removeOverlappingInterval - lineNumber - [((colStart, colEnd), idOcc)] - idOccMap + | Just (_file, (lineNumber, colStart), (_, colEnd)) <- + srcSpanToLineAndColNumbers transformation span + = let idOcc = HCE.IdentifierOccurrence + { internalId = Nothing + , internalIdFromRenamedSource = Nothing + , isBinder = False + , instanceResolution = Nothing + , idOccType = Nothing + , typeArguments = Nothing + , description = "ImportDecl" + , sort = HCE.ModuleId locInfo + } + in IM.insertWith removeOverlappingInterval + lineNumber + [((colStart, colEnd), idOcc)] + idOccMap update idOccMap _ = idOccMap - in L.foldl' update idMap modules + in L.foldl' update idMap modules diff --git a/src/HaskellCodeExplorer/PackageInfo.hs b/src/HaskellCodeExplorer/PackageInfo.hs index af1f478..2f336f4 100644 --- a/src/HaskellCodeExplorer/PackageInfo.hs +++ b/src/HaskellCodeExplorer/PackageInfo.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} @@ -13,370 +12,394 @@ module HaskellCodeExplorer.PackageInfo , testCreatePkgInfo , ghcVersion ) where -import qualified Data.List.NonEmpty as NE -import Control.DeepSeq(deepseq) -import Control.Exception - ( IOException - , SomeAsyncException - , SomeException - , fromException - , throw - , try - ) -import qualified Data.Map as Map -import Control.Monad (foldM, unless, when) -import Control.Monad.Extra (anyM, findM) -import Control.Monad.Logger - ( LoggingT(..) - , MonadLogger(..) - , MonadLoggerIO(..) - , logDebugN - , logErrorN - , logWarnN - , logInfoN - , runStdoutLoggingT - ) -import qualified Data.ByteString as BS -import qualified Data.HashMap.Strict as HM -import Data.IORef (readIORef) -import qualified Data.IntMap.Strict as IM -import qualified Data.List as L -import Data.Maybe - ( fromMaybe - , isJust - , maybeToList - , mapMaybe - ) -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Data.Version (Version(..), showVersion, makeVersion) -import GHC.Data.Graph.Directed (flattenSCCs) -import Distribution.Helper - ( ChComponentName(..) - , ChEntrypoint(..) - , ChModuleName(..) - , ProjLoc(..) - , DistDir(..) - , SCabalProjType(..) - , allUnits - , projectPackages - , pPackageName - , pSourceDir - , pUnits - , uComponentName - , UnitInfo(..) - , ChComponentInfo(..) - , mkQueryEnv - , runQuery - ) -import GHC.Driver.Session - ( gopt_set - , parseDynamicFlagsCmdLine - ) -import Control.Monad.Catch - ( handle - ) -import GHC.Utils.Exception - ( ExceptionMonad - ) -import GHC - ( GhcLink(..) - , Backend(..) - , GhcMode(..) - , DynFlags(..) - , GeneralFlag(..) - , LoadHowMuch(..) - , ModLocation(..) - , ModSummary(..) - , getModuleGraph - , getSession - , getSessionDynFlags - , guessTarget - , load - , noLoc - , parseModule - , runGhcT - , setSessionDynFlags - , setTargets - , topSortModuleGraph - , typecheckModule - , moduleNameString - , moduleName - ) -import GHC.Paths (libdir) -import GHC.Driver.Monad (GhcT(..), liftIO) -import HaskellCodeExplorer.GhcUtils (isHsBoot,toText) -import HaskellCodeExplorer.ModuleInfo - ( ModuleDependencies - , createModuleInfo - ) -import qualified HaskellCodeExplorer.Types as HCE -import GHC.Driver.Env (hsc_EPS, hsc_HPT, hsc_units) -import GHC.Unit.Module.Graph (filterToposortToModules) -import Prelude hiding (id) -import System.Directory - ( doesFileExist - , findExecutable - , setCurrentDirectory - , getCurrentDirectory - , makeAbsolute - , getDirectoryContents - , canonicalizePath - ) -import qualified System.Directory.Tree as DT -import System.Exit (exitFailure) -import System.FilePath - ( () - , addTrailingPathSeparator - , joinPath - , normalise - , replaceExtension - , splitPath - , takeExtension - , takeFileName - , takeBaseName - , takeDirectory - , splitDirectories - ) -import System.FilePath.Find (find,always,(==?),fileName) -import System.Process (readProcess) +import Control.DeepSeq ( deepseq ) +import Control.Exception ( IOException + , SomeAsyncException + , SomeException + , fromException + , throw + , try + ) +import Control.Monad ( foldM + , unless + , when + ) +import Control.Monad.Catch ( handle ) +import Control.Monad.Extra ( anyM + , findM + ) +import Control.Monad.Logger ( LoggingT(..) + , MonadLogger(..) + , MonadLoggerIO(..) + , logDebugN + , logErrorN + , logInfoN + , logWarnN + , runStdoutLoggingT + ) +import qualified Data.ByteString as BS +import qualified Data.HashMap.Strict as HM +import Data.IORef ( readIORef ) +import qualified Data.IntMap.Strict as IM +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import Data.Maybe ( fromMaybe + , isJust + , mapMaybe + , maybeToList + ) +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Version ( Version(..) + , makeVersion + , showVersion + ) +import Distribution.Helper ( ChComponentInfo(..) + , ChComponentName(..) + , ChEntrypoint(..) + , ChModuleName(..) + , DistDir(..) + , ProjLoc(..) + , SCabalProjType(..) + , UnitInfo(..) + , allUnits + , mkQueryEnv + , pPackageName + , pSourceDir + , pUnits + , projectPackages + , runQuery + , uComponentName + ) +import GHC ( Backend(..) + , DynFlags(..) + , GeneralFlag(..) + , GhcLink(..) + , GhcMode(..) + , LoadHowMuch(..) + , ModLocation(..) + , ModSummary(..) + , getModuleGraph + , getSession + , getSessionDynFlags + , guessTarget + , load + , moduleName + , moduleNameString + , noLoc + , parseModule + , runGhcT + , setSessionDynFlags + , setTargets + , topSortModuleGraph + , typecheckModule + ) +import GHC.Data.Graph.Directed ( flattenSCCs ) +import GHC.Driver.Env ( hsc_EPS + , hsc_HPT + , hsc_units + ) +import GHC.Driver.Monad ( GhcT(..) + , liftIO + ) +import GHC.Driver.Session ( gopt_set + , parseDynamicFlagsCmdLine + ) +import GHC.Paths ( libdir ) +import GHC.Unit.Module.Graph ( filterToposortToModules ) +import GHC.Utils.Exception ( ExceptionMonad ) +import HaskellCodeExplorer.GhcUtils ( isHsBoot + , toText + ) +import HaskellCodeExplorer.ModuleInfo ( ModuleDependencies + , createModuleInfo + ) +import qualified HaskellCodeExplorer.Types as HCE +import Prelude hiding ( id ) +import System.Directory ( canonicalizePath + , doesFileExist + , findExecutable + , getCurrentDirectory + , getDirectoryContents + , makeAbsolute + , setCurrentDirectory + ) +import qualified System.Directory.Tree as DT +import System.Exit ( exitFailure ) +import System.FilePath ( () + , addTrailingPathSeparator + , joinPath + , normalise + , replaceExtension + , splitDirectories + , splitPath + , takeBaseName + , takeDirectory + , takeExtension + , takeFileName + ) +import System.FilePath.Find ( (==?) + , always + , fileName + , find + ) +import System.Process ( readProcess ) testCreatePkgInfo :: FilePath -> IO (HCE.PackageInfo HCE.ModuleInfo) -testCreatePkgInfo pkgPath = runStdoutLoggingT $ - createPackageInfo pkgPath Nothing HCE.AfterPreprocessing [] [] +testCreatePkgInfo pkgPath = runStdoutLoggingT + $ createPackageInfo pkgPath Nothing HCE.AfterPreprocessing [] [] -createPackageInfo :: - FilePath -- ^ Path to a Cabal package +createPackageInfo + :: FilePath -- ^ Path to a Cabal package -> Maybe FilePath -- ^ Relative path to a dist directory -> HCE.SourceCodePreprocessing -- ^ Before or after preprocessor -> [String] -- ^ Options for GHC -> [String] -- ^ Directories to ignore -> LoggingT IO (HCE.PackageInfo HCE.ModuleInfo) -createPackageInfo packageDirectoryPath mbDistDirRelativePath sourceCodePreprocessing additionalGhcOptions ignoreDirectories = do - packageDirectoryAbsPath <- liftIO $ makeAbsolute packageDirectoryPath - currentDirectory <- liftIO getCurrentDirectory - liftIO $ setCurrentDirectory packageDirectoryAbsPath - distDir <- - case mbDistDirRelativePath of +createPackageInfo packageDirectoryPath mbDistDirRelativePath sourceCodePreprocessing additionalGhcOptions ignoreDirectories + = do + packageDirectoryAbsPath <- liftIO $ makeAbsolute packageDirectoryPath + currentDirectory <- liftIO getCurrentDirectory + liftIO $ setCurrentDirectory packageDirectoryAbsPath + distDir <- case mbDistDirRelativePath of Just path -> return $ packageDirectoryAbsPath path - Nothing -> return $ packageDirectoryAbsPath "dist-newstyle" - cabalFiles <- - liftIO $ - length . - filter - (\path -> takeFileName path /= ".cabal" && takeExtension path == ".cabal") <$> - getDirectoryContents packageDirectoryAbsPath - _ <- - if cabalFiles == 0 + Nothing -> return $ packageDirectoryAbsPath "dist-newstyle" + cabalFiles <- + liftIO + $ length + . filter + (\path -> + takeFileName path /= ".cabal" && takeExtension path == ".cabal" + ) + <$> getDirectoryContents packageDirectoryAbsPath + _ <- if cabalFiles == 0 then do - logErrorN $ - T.concat ["No .cabal file found in ", T.pack packageDirectoryAbsPath] + logErrorN $ T.concat + ["No .cabal file found in ", T.pack packageDirectoryAbsPath] liftIO exitFailure else when (cabalFiles >= 2) $ do - logErrorN $ - T.concat - [ "Found more than one .cabal file in " - , T.pack packageDirectoryAbsPath - ] - liftIO exitFailure - cabalHelperQueryEnv <- liftIO $ - mkQueryEnv - (ProjLocV2Dir packageDirectoryAbsPath) - (DistDirCabal SCV2 distDir) - packages <- liftIO $ NE.toList <$> runQuery projectPackages cabalHelperQueryEnv - logDebugN $ "packages: " <> - (T.pack $ show $ zip3 (pPackageName <$> packages) (pSourceDir <$> packages) ((mapMaybe uComponentName . NE.toList . pUnits) <$> packages)) - mbPackage <- liftIO $ - findM - (\pkg -> do + logErrorN + $ T.concat + [ "Found more than one .cabal file in " + , T.pack packageDirectoryAbsPath + ] + liftIO exitFailure + cabalHelperQueryEnv <- liftIO $ mkQueryEnv + (ProjLocV2Dir packageDirectoryAbsPath) + (DistDirCabal SCV2 distDir) + packages <- + liftIO $ NE.toList <$> runQuery projectPackages cabalHelperQueryEnv + logDebugN + $ "packages: " + <> (T.pack $ show $ zip3 + (pPackageName <$> packages) + (pSourceDir <$> packages) + ((mapMaybe uComponentName . NE.toList . pUnits) <$> packages) + ) + mbPackage <- liftIO $ findM + (\pkg -> do dir1 <- (canonicalizePath . pSourceDir) pkg dir2 <- canonicalizePath packageDirectoryAbsPath - return $ dir1 == dir2) - packages - package <- - case mbPackage of + return $ dir1 == dir2 + ) + packages + package <- case mbPackage of Just package' -> return package' - Nothing -> do - logWarnN $ - "Cannot find a package with sourceDir in the same directory (" + Nothing -> do + logWarnN + $ "Cannot find a package with sourceDir in the same directory (" <> T.pack (packageDirectoryAbsPath "") <> "), indexing the first package by default." <> "Alternatively, try using absolute path for -p." return $ head packages - - units <- - liftIO $ - (filter (\((pkgName, _), _, _) -> pkgName == pPackageName package)) . NE.toList <$> - runQuery - (allUnits - (\unit -> - (uiPackageId unit, uiCompilerId unit, - map (\comp -> ((ciGhcOptions comp, ciComponentName comp), - (ciEntrypoints comp, ciComponentName comp), - (ciSourceDirs comp, ciComponentName comp))) $ - (Map.elems . uiComponents) unit))) - cabalHelperQueryEnv - -- TODO: we are assuming all pakcageVersion and packageCompilerVersion are the same - let ((packageName, packageVersion), (_, packageCompilerVersion), _) = head units - compInfo = concatMap (\(_, _, comp) -> comp) units - currentPackageId = HCE.PackageId (T.pack packageName) packageVersion - logDebugN $ "compinfo: " <> (T.pack $ show compInfo) - unless - (take 3 (versionBranch packageCompilerVersion) == - take 3 (versionBranch ghcVersion)) $ do - logErrorN $ - T.concat - [ "GHC version mismatch. haskell-code-indexer: " - , T.pack $ showVersion ghcVersion - , ", package: " - , T.pack $ showVersion packageCompilerVersion - ] - liftIO exitFailure - logInfoN $ T.append "Indexing " $ HCE.packageIdToText currentPackageId - let buildComponents = - L.map - (\((options, compName), (entrypoint, _), (srcDirs, _)) -> - ( chComponentNameToComponentId compName - , options - , chEntrypointsToModules entrypoint - , srcDirs - , chComponentNameToComponentType compName)) . - L.sortBy - (\((_, compName1), _, _) ((_, compName2), _, _) -> - compare compName1 compName2) $ - compInfo - libSrcDirs = - concatMap (\(_, _, _, srcDirs, _) -> srcDirs) . - filter (\(_, _, _, _, compType) -> HCE.isLibrary compType) $ + + units <- + liftIO + $ (filter (\((pkgName, _), _, _) -> pkgName == pPackageName package)) + . NE.toList + <$> runQuery + (allUnits + (\unit -> + ( uiPackageId unit + , uiCompilerId unit + , map + (\comp -> + ( (ciGhcOptions comp , ciComponentName comp) + , (ciEntrypoints comp, ciComponentName comp) + , (ciSourceDirs comp , ciComponentName comp) + ) + ) + $ (Map.elems . uiComponents) unit + ) + ) + ) + cabalHelperQueryEnv + -- TODO: we are assuming all pakcageVersion and packageCompilerVersion are the same + let ((packageName, packageVersion), (_, packageCompilerVersion), _) = + head units + compInfo = concatMap (\(_, _, comp) -> comp) units + currentPackageId = HCE.PackageId (T.pack packageName) packageVersion + logDebugN $ "compinfo: " <> (T.pack $ show compInfo) + unless + ( take 3 (versionBranch packageCompilerVersion) + == take 3 (versionBranch ghcVersion) + ) + $ do + logErrorN $ T.concat + [ "GHC version mismatch. haskell-code-indexer: " + , T.pack $ showVersion ghcVersion + , ", package: " + , T.pack $ showVersion packageCompilerVersion + ] + liftIO exitFailure + logInfoN $ T.append "Indexing " $ HCE.packageIdToText currentPackageId + let buildComponents = + L.map + (\((options, compName), (entrypoint, _), (srcDirs, _)) -> + ( chComponentNameToComponentId compName + , options + , chEntrypointsToModules entrypoint + , srcDirs + , chComponentNameToComponentType compName + ) + ) + . L.sortBy + (\((_, compName1), _, _) ((_, compName2), _, _) -> + compare compName1 compName2 + ) + $ compInfo + libSrcDirs = + concatMap (\(_, _, _, srcDirs, _) -> srcDirs) + . filter (\(_, _, _, _, compType) -> HCE.isLibrary compType) + $ buildComponents + (indexedModules, (_fileMapResult, _defSiteMapResult, modNameMapResult)) <- + foldM + (\(modules, (fileMap, defSiteMap, modNameMap)) (compId, options, (mbMain, moduleNames), srcDirs, _) -> + do + mbMainPath <- case mbMain of + Just mainPath -> + liftIO + $ findM doesFileExist + $ mainPath + : map (\srcDir -> normalise $ srcDir mainPath) srcDirs + Nothing -> return Nothing + (modules', (fileMap', defSiteMap', modNameMap')) <- + indexBuildComponent + sourceCodePreprocessing + currentPackageId + compId + (fileMap, defSiteMap, modNameMap) + srcDirs + libSrcDirs + (options ++ additionalGhcOptions) + (maybe moduleNames (: moduleNames) mbMainPath) + return (modules ++ modules', (fileMap', defSiteMap', modNameMap')) + ) + ([], (HM.empty, HM.empty, HM.empty)) buildComponents - (indexedModules, (_fileMapResult, _defSiteMapResult, modNameMapResult)) <- - foldM - (\(modules, (fileMap, defSiteMap, modNameMap)) (compId, options, (mbMain, moduleNames), srcDirs, _) -> do - mbMainPath <- - case mbMain of - Just mainPath -> - liftIO $ - findM doesFileExist $ - mainPath : - map (\srcDir -> normalise $ srcDir mainPath) srcDirs - Nothing -> return Nothing - (modules', (fileMap', defSiteMap', modNameMap')) <- - indexBuildComponent - sourceCodePreprocessing - currentPackageId - compId - (fileMap, defSiteMap, modNameMap) - srcDirs - libSrcDirs - (options ++ additionalGhcOptions) - (maybe moduleNames (: moduleNames) mbMainPath) - return (modules ++ modules', (fileMap', defSiteMap', modNameMap'))) - ([], (HM.empty, HM.empty, HM.empty)) - buildComponents - let modId = HCE.id :: HCE.ModuleInfo -> HCE.HaskellModulePath - moduleMap = - HM.fromList . map (\modInfo -> (modId modInfo, modInfo)) $ - indexedModules - references = L.foldl' addReferencesFromModule HM.empty indexedModules - moduleId = HCE.id :: HCE.ModuleInfo -> HCE.HaskellModulePath - topLevelIdentifiersTrie = - L.foldl' addTopLevelIdentifiersFromModule HCE.emptyTrie . - L.filter (not . isHsBoot . moduleId) $ - indexedModules - directoryTree <- - liftIO $ - buildDirectoryTree + let modId = HCE.id :: HCE.ModuleInfo -> HCE.HaskellModulePath + moduleMap = + HM.fromList + . map (\modInfo -> (modId modInfo, modInfo)) + $ indexedModules + references = L.foldl' addReferencesFromModule HM.empty indexedModules + moduleId = HCE.id :: HCE.ModuleInfo -> HCE.HaskellModulePath + topLevelIdentifiersTrie = + L.foldl' addTopLevelIdentifiersFromModule HCE.emptyTrie + . L.filter (not . isHsBoot . moduleId) + $ indexedModules + directoryTree <- liftIO $ buildDirectoryTree packageDirectoryAbsPath ignoreDirectories (\path -> HM.member (HCE.HaskellModulePath . T.pack $ path) moduleMap) - liftIO $ setCurrentDirectory currentDirectory - return - HCE.PackageInfo - { id = currentPackageId - , moduleMap = moduleMap - , moduleNameMap = modNameMapResult - , directoryTree = directoryTree - , externalIdOccMap = references - , externalIdInfoMap = topLevelIdentifiersTrie - } - where - chEntrypointsToModules :: ChEntrypoint -> (Maybe String, [String]) - chEntrypointsToModules (ChLibEntrypoint modules otherModules signatures) = - ( Nothing - , L.map chModuleToString modules ++ - L.map chModuleToString otherModules ++ L.map chModuleToString signatures) - chEntrypointsToModules (ChExeEntrypoint mainModule _otherModules) = - (Just mainModule, []) - chEntrypointsToModules (ChSetupEntrypoint _) = (Nothing, []) - chModuleToString :: ChModuleName -> String - chModuleToString (ChModuleName n) = n - chComponentNameToComponentType :: ChComponentName -> HCE.ComponentType - chComponentNameToComponentType ChSetupHsName = HCE.Setup - chComponentNameToComponentType (ChLibName _) = HCE.Lib - chComponentNameToComponentType (ChFLibName name) = HCE.FLib $ T.pack name - chComponentNameToComponentType (ChExeName name) = HCE.Exe $ T.pack name - chComponentNameToComponentType (ChTestName name) = HCE.Test $ T.pack name - chComponentNameToComponentType (ChBenchName name) = HCE.Bench $ T.pack name - chComponentNameToComponentId :: ChComponentName -> HCE.ComponentId - chComponentNameToComponentId (ChLibName _) = HCE.ComponentId "lib" - chComponentNameToComponentId (ChFLibName name) = - HCE.ComponentId . T.append "flib-" . T.pack $ name - chComponentNameToComponentId (ChExeName name) = - HCE.ComponentId . T.append "exe-" . T.pack $ name - chComponentNameToComponentId (ChTestName name) = - HCE.ComponentId . T.append "test-" . T.pack $ name - chComponentNameToComponentId (ChBenchName name) = - HCE.ComponentId . T.append "bench-" . T.pack $ name - chComponentNameToComponentId ChSetupHsName = HCE.ComponentId "setup" + liftIO $ setCurrentDirectory currentDirectory + return HCE.PackageInfo { id = currentPackageId + , moduleMap = moduleMap + , moduleNameMap = modNameMapResult + , directoryTree = directoryTree + , externalIdOccMap = references + , externalIdInfoMap = topLevelIdentifiersTrie + } + where + chEntrypointsToModules :: ChEntrypoint -> (Maybe String, [String]) + chEntrypointsToModules (ChLibEntrypoint modules otherModules signatures) = + ( Nothing + , L.map chModuleToString modules + ++ L.map chModuleToString otherModules + ++ L.map chModuleToString signatures + ) + chEntrypointsToModules (ChExeEntrypoint mainModule _otherModules) = + (Just mainModule, []) + chEntrypointsToModules (ChSetupEntrypoint _) = (Nothing, []) + chModuleToString :: ChModuleName -> String + chModuleToString (ChModuleName n) = n + chComponentNameToComponentType :: ChComponentName -> HCE.ComponentType + chComponentNameToComponentType ChSetupHsName = HCE.Setup + chComponentNameToComponentType (ChLibName _ ) = HCE.Lib + chComponentNameToComponentType (ChFLibName name) = HCE.FLib $ T.pack name + chComponentNameToComponentType (ChExeName name) = HCE.Exe $ T.pack name + chComponentNameToComponentType (ChTestName name) = HCE.Test $ T.pack name + chComponentNameToComponentType (ChBenchName name) = HCE.Bench $ T.pack name + chComponentNameToComponentId :: ChComponentName -> HCE.ComponentId + chComponentNameToComponentId (ChLibName _) = HCE.ComponentId "lib" + chComponentNameToComponentId (ChFLibName name) = + HCE.ComponentId . T.append "flib-" . T.pack $ name + chComponentNameToComponentId (ChExeName name) = + HCE.ComponentId . T.append "exe-" . T.pack $ name + chComponentNameToComponentId (ChTestName name) = + HCE.ComponentId . T.append "test-" . T.pack $ name + chComponentNameToComponentId (ChBenchName name) = + HCE.ComponentId . T.append "bench-" . T.pack $ name + chComponentNameToComponentId ChSetupHsName = HCE.ComponentId "setup" ghcVersion :: Version ghcVersion = makeVersion [9, 2, 2, 0] -buildDirectoryTree :: FilePath -> [FilePath] -> (FilePath -> Bool) -> IO HCE.DirTree +buildDirectoryTree + :: FilePath -> [FilePath] -> (FilePath -> Bool) -> IO HCE.DirTree buildDirectoryTree path ignoreDirectories isHaskellModule = do (_dir DT.:/ tree) <- DT.readDirectoryWith (const . return $ ()) path -- Tuple up the complete file path with the file contents, by building up the path, -- trie-style, from the root. The filepath will be relative to "anchored" directory. let treeWithPaths = DT.zipPaths ("" DT.:/ DT.filterDir (not . ignore) tree) return $ toDirTree (removeTopDir . fst <$> treeWithPaths) - where - ignore :: DT.DirTree a -> Bool - ignore (DT.Dir dirName _) - | "." `L.isPrefixOf` dirName = True - | dirName == "dist" = True - | dirName == "dist-newstyle" = True - | dirName == "tmp" = True - | otherwise = dirName `elem` ignoreDirectories - ignore (DT.Failed _ _) = True - ignore _ = False - removeTopDir :: FilePath -> FilePath - removeTopDir p = - case splitPath p of - _x:xs -> joinPath xs - [] -> "" - toDirTree :: DT.DirTree FilePath -> HCE.DirTree - toDirTree (DT.Dir name contents) = - HCE.Dir name (map toDirTree . filter (not . DT.failed) $ contents) - toDirTree (DT.File name filePath) = - HCE.File name filePath (isHaskellModule filePath) - toDirTree (DT.Failed name err) = - HCE.File (name ++ " : " ++ show err) "" False + where + ignore :: DT.DirTree a -> Bool + ignore (DT.Dir dirName _) | "." `L.isPrefixOf` dirName = True + | dirName == "dist" = True + | dirName == "dist-newstyle" = True + | dirName == "tmp" = True + | otherwise = dirName `elem` ignoreDirectories + ignore (DT.Failed _ _) = True + ignore _ = False + removeTopDir :: FilePath -> FilePath + removeTopDir p = case splitPath p of + _x : xs -> joinPath xs + [] -> "" + toDirTree :: DT.DirTree FilePath -> HCE.DirTree + toDirTree (DT.Dir name contents) = + HCE.Dir name (map toDirTree . filter (not . DT.failed) $ contents) + toDirTree (DT.File name filePath) = + HCE.File name filePath (isHaskellModule filePath) + toDirTree (DT.Failed name err) = + HCE.File (name ++ " : " ++ show err) "" False -addTopLevelIdentifiersFromModule :: - HCE.Trie Char HCE.ExternalIdentifierInfo +addTopLevelIdentifiersFromModule + :: HCE.Trie Char HCE.ExternalIdentifierInfo -> HCE.ModuleInfo -> HCE.Trie Char HCE.ExternalIdentifierInfo -addTopLevelIdentifiersFromModule trieIdInfo HCE.ModuleInfo {..} = - L.foldl' - (\trie idInfo@(HCE.ExternalIdentifierInfo HCE.IdentifierInfo {..}) -> - HCE.insertToTrie S.insert (T.unpack demangledOccName) idInfo trie) - trieIdInfo - externalIds +addTopLevelIdentifiersFromModule trieIdInfo HCE.ModuleInfo {..} = L.foldl' + (\trie idInfo@(HCE.ExternalIdentifierInfo HCE.IdentifierInfo {..}) -> + HCE.insertToTrie S.insert (T.unpack demangledOccName) idInfo trie + ) + trieIdInfo + externalIds -addReferencesFromModule :: - HM.HashMap HCE.ExternalId (S.Set HCE.IdentifierSrcSpan) +addReferencesFromModule + :: HM.HashMap HCE.ExternalId (S.Set HCE.IdentifierSrcSpan) -> HCE.ModuleInfo -> HM.HashMap HCE.ExternalId (S.Set HCE.IdentifierSrcSpan) addReferencesFromModule references modInfo@HCE.ModuleInfo {..} = @@ -384,40 +407,36 @@ addReferencesFromModule references modInfo@HCE.ModuleInfo {..} = references modInfo (\occMap lineNumber startCol endCol occ -> - let mbIdExternalId = - HCE.externalId =<< - maybe - Nothing - (`HM.lookup` idInfoMap) - (HCE.internalId (occ :: HCE.IdentifierOccurrence)) - idSrcSpan = - HCE.IdentifierSrcSpan - { modulePath = id - , line = lineNumber - , startColumn = startCol - , endColumn = endCol - } - in case mbIdExternalId of - Just externalId -> - HM.insertWith S.union externalId (S.singleton idSrcSpan) occMap - Nothing -> occMap) + let mbIdExternalId = HCE.externalId =<< maybe + Nothing + (`HM.lookup` idInfoMap) + (HCE.internalId (occ :: HCE.IdentifierOccurrence)) + idSrcSpan = HCE.IdentifierSrcSpan { modulePath = id + , line = lineNumber + , startColumn = startCol + , endColumn = endCol + } + in case mbIdExternalId of + Just externalId -> + HM.insertWith S.union externalId (S.singleton idSrcSpan) occMap + Nothing -> occMap + ) -eachIdentifierOccurrence :: - forall a. - a +eachIdentifierOccurrence + :: forall a + . a -> HCE.ModuleInfo -> (a -> IM.Key -> Int -> Int -> HCE.IdentifierOccurrence -> a) -> a -eachIdentifierOccurrence accumulator HCE.ModuleInfo {..} f = - IM.foldlWithKey' - (\acc lineNumber occurences -> - L.foldl' - (\a ((startCol, endCol), occ) -> f a lineNumber startCol endCol occ) - acc - occurences) - accumulator - idOccMap +eachIdentifierOccurrence accumulator HCE.ModuleInfo {..} f = IM.foldlWithKey' + (\acc lineNumber occurences -> L.foldl' + (\a ((startCol, endCol), occ) -> f a lineNumber startCol endCol occ) + acc + occurences + ) + accumulator + idOccMap instance MonadLoggerIO (GhcT (LoggingT IO)) where askLoggerIO = GhcT $ const askLoggerIO @@ -430,15 +449,14 @@ gtrySync :: (ExceptionMonad m) => m a -> m (Either SomeException a) gtrySync action = ghandleSync (return . Left) (fmap Right action) ghandleSync :: (ExceptionMonad m) => (SomeException -> m a) -> m a -> m a -ghandleSync onError = - handle - (\ex -> - case fromException ex of - Just (asyncEx :: SomeAsyncException) -> throw asyncEx - _ -> onError ex) +ghandleSync onError = handle + (\ex -> case fromException ex of + Just (asyncEx :: SomeAsyncException) -> throw asyncEx + _ -> onError ex + ) -indexBuildComponent :: - HCE.SourceCodePreprocessing -- ^ Before or after preprocessor +indexBuildComponent + :: HCE.SourceCodePreprocessing -- ^ Before or after preprocessor -> HCE.PackageId -- ^ Current package id -> HCE.ComponentId -- ^ Current component id -> ModuleDependencies -- ^ Already indexed modules @@ -446,133 +464,125 @@ indexBuildComponent :: -> [FilePath] -- ^ Src dirs of libraries -> [String] -- ^ Command-line options for GHC -> [String] -- ^ Modules to compile - -> LoggingT IO ([HCE.ModuleInfo],ModuleDependencies) -indexBuildComponent sourceCodePreprocessing currentPackageId componentId deps@(fileMap, defSiteMap, modNameMap) srcDirs libSrcDirs options modules = do - let onError ex = do - logErrorN $ - T.concat + -> LoggingT IO ([HCE.ModuleInfo], ModuleDependencies) +indexBuildComponent sourceCodePreprocessing currentPackageId componentId deps@(fileMap, defSiteMap, modNameMap) srcDirs libSrcDirs options modules + = do + let onError ex = do + logErrorN $ T.concat [ "Error while indexing component " , HCE.getComponentId componentId , " : " , T.pack . show $ ex ] - return ([], deps) - ghandleSync onError $ - runGhcT (Just libdir) $ do + return ([], deps) + ghandleSync onError $ runGhcT (Just libdir) $ do logDebugN (T.append "Component id : " $ HCE.getComponentId componentId) logDebugN (T.append "Modules : " $ T.pack $ show modules) logDebugN - (T.append "GHC command line options : " $ - T.pack $ L.unwords (options ++ modules)) - flags <- getSessionDynFlags - (flags', _, _) <- - parseDynamicFlagsCmdLine - flags - (L.map noLoc . L.filter ("-Werror" /=) $ options) -- -Werror flag makes warnings fatal - let mbTmpDir = - case hiDir flags' of - Just buildDir -> - Just $ buildDir (takeBaseName buildDir ++ "-tmp") - Nothing -> Nothing + (T.append "GHC command line options : " $ T.pack $ L.unwords + (options ++ modules) + ) + flags <- getSessionDynFlags + (flags', _, _) <- parseDynamicFlagsCmdLine + flags + (L.map noLoc . L.filter ("-Werror" /=) $ options) -- -Werror flag makes warnings fatal + let mbTmpDir = case hiDir flags' of + Just buildDir -> + Just $ buildDir (takeBaseName buildDir ++ "-tmp") + Nothing -> Nothing _ <- -- initUnits happens here - setSessionDynFlags $ - L.foldl' - gopt_set - (flags' - { backend = NCG - , ghcLink = LinkInMemory - , ghcMode = CompManager - , importPaths = importPaths flags' ++ maybeToList mbTmpDir - }) - [Opt_Haddock] + setSessionDynFlags $ L.foldl' + gopt_set + (flags' { backend = NCG + , ghcLink = LinkInMemory + , ghcMode = CompManager + , importPaths = importPaths flags' ++ maybeToList mbTmpDir + } + ) + [Opt_Haddock] targets <- mapM (`guessTarget` Nothing) modules setTargets targets - _ <- load LoadAllTargets + _ <- load LoadAllTargets modGraph <- getModuleGraph - let topSortMods = - flattenSCCs $ - filterToposortToModules (topSortModuleGraph False modGraph Nothing) + let topSortMods = flattenSCCs $ filterToposortToModules + (topSortModuleGraph False modGraph Nothing) buildDir = - addTrailingPathSeparator . normalise . fromMaybe "" . hiDir $ - flags' - pathsModuleName = - "Paths_" ++ - map - (\c -> - if c == '-' - then '_' - else c) - (T.unpack (HCE.name (currentPackageId :: HCE.PackageId))) + addTrailingPathSeparator . normalise . fromMaybe "" . hiDir $ flags' + pathsModuleName = "Paths_" ++ map + (\c -> if c == '-' then '_' else c) + (T.unpack (HCE.name (currentPackageId :: HCE.PackageId))) (modSumWithPath, modulesNotFound) <- (\(mods, notFound) -> - ( L.reverse . - L.foldl' - (\acc (mbPath, modSum) -> - case mbPath of - Just path - | not $ HM.member path defSiteMap -> (path, modSum) : acc - _ -> acc) - [] $ - mods - , map snd notFound)) . - L.partition (\(mbPath, _) -> isJust mbPath) <$> - mapM - (\modSum -> - liftIO $ - (, modSum) <$> - findHaskellModulePath buildDir (srcDirs ++ libSrcDirs) modSum) - (filter - (\modSum -> - pathsModuleName /= - (moduleNameString . moduleName $ ms_mod modSum)) - topSortMods) - unless (null modulesNotFound) $ - logErrorN $ - T.append - "Cannot find module path : " - (toText flags' $ map ms_mod modulesNotFound) + ( L.reverse + . L.foldl' + (\acc (mbPath, modSum) -> case mbPath of + Just path | not $ HM.member path defSiteMap -> + (path, modSum) : acc + _ -> acc + ) + [] + $ mods + , map snd notFound + ) + ) + . L.partition (\(mbPath, _) -> isJust mbPath) + <$> mapM + (\modSum -> + liftIO + $ (, modSum) + <$> findHaskellModulePath buildDir + (srcDirs ++ libSrcDirs) + modSum + ) + (filter + (\modSum -> + pathsModuleName + /= (moduleNameString . moduleName $ ms_mod modSum) + ) + topSortMods + ) + unless (null modulesNotFound) $ logErrorN $ T.append + "Cannot find module path : " + (toText flags' $ map ms_mod modulesNotFound) foldM - (\(indexedModules, (fileMap', defSiteMap', modNameMap')) (modulePath, modSum) -> do - result <- - indexModule - sourceCodePreprocessing - componentId - currentPackageId - flags' - (fileMap', defSiteMap', modNameMap') - (modulePath, modSum) - case result of - Right (modInfo, (fileMap'', defSiteMap'', modNameMap'')) -> - return - ( modInfo : indexedModules - , (fileMap'', defSiteMap'', modNameMap'')) - Left exception -> do - logErrorN $ - T.concat - [ "Error while indexing " - , T.pack . show $ modulePath - , " : " - , T.pack . show $ exception - ] - return (indexedModules, (fileMap', defSiteMap', modNameMap'))) + (\(indexedModules, (fileMap', defSiteMap', modNameMap')) (modulePath, modSum) -> + do + result <- indexModule sourceCodePreprocessing + componentId + currentPackageId + flags' + (fileMap', defSiteMap', modNameMap') + (modulePath, modSum) + case result of + Right (modInfo, (fileMap'', defSiteMap'', modNameMap'')) -> + return + ( modInfo : indexedModules + , (fileMap'', defSiteMap'', modNameMap'') + ) + Left exception -> do + logErrorN $ T.concat + [ "Error while indexing " + , T.pack . show $ modulePath + , " : " + , T.pack . show $ exception + ] + return (indexedModules, (fileMap', defSiteMap', modNameMap')) + ) ([], (fileMap, defSiteMap, modNameMap)) modSumWithPath -findHaskellModulePath :: - FilePath -> [FilePath] -> ModSummary -> IO (Maybe HCE.HaskellModulePath) +findHaskellModulePath + :: FilePath -> [FilePath] -> ModSummary -> IO (Maybe HCE.HaskellModulePath) findHaskellModulePath buildDir srcDirs modSum = case normalise <$> (ml_hs_file . ms_location $ modSum) of Just modulePath -> let toHaskellModulePath = return . Just . HCE.HaskellModulePath . T.pack - removeTmpDir path = - case splitDirectories path of - parent:rest -> - if "-tmp" `L.isSuffixOf` parent - then joinPath rest - else path - _ -> path - in case removeTmpDir <$> L.stripPrefix buildDir modulePath of + removeTmpDir path = case splitDirectories path of + parent : rest -> + if "-tmp" `L.isSuffixOf` parent then joinPath rest else path + _ -> path + in case removeTmpDir <$> L.stripPrefix buildDir modulePath of -- File is in the build directory Just path | takeExtension path == ".hs-boot" -> do @@ -580,43 +590,45 @@ findHaskellModulePath buildDir srcDirs modSum = mbFoundPath <- findM doesFileExist possiblePaths case mbFoundPath of Just p -> toHaskellModulePath p - _ -> return Nothing + _ -> return Nothing | takeExtension path == ".hs" -> do - let paths = - map - (replaceExtension path) - HCE.haskellPreprocessorExtensions - possiblePaths = - paths ++ - concatMap (\srcDir -> map (srcDir ) paths) srcDirs + let + paths = map (replaceExtension path) + HCE.haskellPreprocessorExtensions + possiblePaths = + paths + ++ concatMap (\srcDir -> map (srcDir ) paths) srcDirs mbFoundPath <- findM doesFileExist possiblePaths case mbFoundPath of Just p -> toHaskellModulePath p - _ -> return Nothing + _ -> return Nothing | otherwise -> return Nothing Nothing -> toHaskellModulePath modulePath Nothing -> return Nothing -indexModule :: - HCE.SourceCodePreprocessing +indexModule + :: HCE.SourceCodePreprocessing -> HCE.ComponentId -> HCE.PackageId -> DynFlags -> ModuleDependencies -> (HCE.HaskellModulePath, ModSummary) - -> GhcT (LoggingT IO) (Either SomeException ( HCE.ModuleInfo - , ModuleDependencies)) -indexModule sourceCodePreprocessing componentId currentPackageId flags deps (modulePath, modSum) = - gtrySync $ do + -> GhcT + (LoggingT IO) + ( Either + SomeException + (HCE.ModuleInfo, ModuleDependencies) + ) +indexModule sourceCodePreprocessing componentId currentPackageId flags deps (modulePath, modSum) + = gtrySync $ do logDebugN (T.append "Indexing " $ HCE.getHaskellModulePath modulePath) - parsedModule <- parseModule modSum - typecheckedModule <- typecheckModule parsedModule - hscEnv <- getSession + parsedModule <- parseModule modSum + typecheckedModule <- typecheckModule parsedModule + hscEnv <- getSession externalPackageState <- liftIO . readIORef . hsc_EPS $ hscEnv - originalSourceCode <- - liftIO $ - T.replace "\t" " " . TE.decodeUtf8 <$> - BS.readFile (T.unpack . HCE.getHaskellModulePath $ modulePath) + originalSourceCode <- + liftIO $ T.replace "\t" " " . TE.decodeUtf8 <$> BS.readFile + (T.unpack . HCE.getHaskellModulePath $ modulePath) let (modInfo, (fileMap', exportMap', moduleNameMap'), typeErrors) = createModuleInfo deps @@ -625,11 +637,15 @@ indexModule sourceCodePreprocessing componentId currentPackageId flags deps (mod , typecheckedModule , hsc_HPT hscEnv , externalPackageState - , modSum) + , modSum + ) modulePath currentPackageId componentId (originalSourceCode, sourceCodePreprocessing) - unless (null typeErrors) $ - logInfoN $ T.append "Type errors : " $ T.pack $ show typeErrors + unless (null typeErrors) + $ logInfoN + $ T.append "Type errors : " + $ T.pack + $ show typeErrors deepseq modInfo $ return (modInfo, (fileMap', exportMap', moduleNameMap')) -- cgit v1.2.3