aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorYuchen Pei <hi@ypei.me>2022-06-08 23:29:46 +1000
committerYuchen Pei <hi@ypei.me>2022-06-08 23:29:46 +1000
commit069ae2042ed716211fba513b8243fb7950a19bbf (patch)
tree117507256ba02d8af60be6351e02687cf39b4bf6
parent3e46f1ae9eeabd0e7aabaa8b4b52a05dba774e51 (diff)
removed all CPP macros, and formatted code with brittany
Diffstat
-rw-r--r--src/HaskellCodeExplorer/AST/RenamedSource.hs756
-rw-r--r--src/HaskellCodeExplorer/AST/TypecheckedSource.hs1419
-rw-r--r--src/HaskellCodeExplorer/GhcUtils.hs1528
-rw-r--r--src/HaskellCodeExplorer/ModuleInfo.hs1307
-rw-r--r--src/HaskellCodeExplorer/PackageInfo.hs1000
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 "<unknown file>") 0 0
- pstate = initParserState (initParserOpts dflags) buffer realSrcLc
- in case unP parseIdentifier pstate of
- POk _ name -> Just (unLoc name)
- _ -> Nothing
+ pstate = initParserState (initParserOpts dflags) buffer realSrcLc
+ in case unP parseIdentifier pstate of
+ POk _ name -> Just (unLoc name)
+ _ -> Nothing
type Doc id = DocH (ModuleName, OccName) id
rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
rename dflags gre = rn
- where
- rn :: Doc RdrName -> Doc Name
- rn d = case d of
- DocAppend a b -> DocAppend (rn a) (rn b)
- DocParagraph doc -> DocParagraph (rn doc)
- DocIdentifier x -> do
- -- Generate the choices for the possible kind of thing this
- -- is.
- let choices = dataTcOccs x
- -- Try to look up all the names in the GlobalRdrEnv that match
- -- the names.
- let names = concatMap (\c -> map grePrintableName (lookupGRE_RdrName c gre)) choices
-
- case names of
- -- We found no names in the env so we start guessing.
- [] ->
- case choices of
- [] -> DocMonospaced (DocString (showPpr dflags x))
- -- There was nothing in the environment so we need to
- -- pick some default from what's available to us. We
- -- diverge here from the old way where we would default
- -- to type constructors as we're much more likely to
- -- actually want anchors to regular definitions than
- -- type constructor names (such as in #253). So now we
- -- only get type constructor links if they are actually
- -- in scope.
- a:_ -> outOfScope dflags a
-
- -- There is only one name in the environment that matches so
- -- use it.
- [a] -> DocIdentifier a
- -- But when there are multiple names available, default to
- -- type constructors: somewhat awfully GHC returns the
- -- values in the list positionally.
- a:b:_ | isTyConName a -> DocIdentifier a
- | otherwise -> DocIdentifier b
-
- DocWarning doc -> DocWarning (rn doc)
- DocEmphasis doc -> DocEmphasis (rn doc)
- DocBold doc -> DocBold (rn doc)
- DocMonospaced doc -> DocMonospaced (rn doc)
- DocUnorderedList docs -> DocUnorderedList (map rn docs)
- DocOrderedList docs -> DocOrderedList (map rn docs)
- DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ]
- DocCodeBlock doc -> DocCodeBlock (rn doc)
- DocIdentifierUnchecked x -> DocIdentifierUnchecked x
- DocModule modLink -> DocModule (rn <$> modLink)
- DocHyperlink hyperLink -> DocHyperlink (rn <$> hyperLink)
- DocPic str -> DocPic str
- DocMathInline str -> DocMathInline str
- DocMathDisplay str -> DocMathDisplay str
- DocAName str -> DocAName str
- DocProperty p -> DocProperty p
- DocExamples e -> DocExamples e
- DocEmpty -> DocEmpty
- DocString str -> DocString str
- DocHeader (Header l t) -> DocHeader $ Header l (rn t)
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
- DocTable t -> DocTable (rn <$> t)
-#endif
+ where
+ rn :: Doc RdrName -> Doc Name
+ rn d = case d of
+ DocAppend a b -> DocAppend (rn a) (rn b)
+ DocParagraph doc -> DocParagraph (rn doc)
+ DocIdentifier x -> do
+ -- Generate the choices for the possible kind of thing this
+ -- is.
+ let choices = dataTcOccs x
+ -- Try to look up all the names in the GlobalRdrEnv that match
+ -- the names.
+ let names = concatMap
+ (\c -> map grePrintableName (lookupGRE_RdrName c gre))
+ choices
+
+ case names of
+ -- We found no names in the env so we start guessing.
+ [] -> case choices of
+ [] -> DocMonospaced (DocString (showPpr dflags x))
+ -- There was nothing in the environment so we need to
+ -- pick some default from what's available to us. We
+ -- diverge here from the old way where we would default
+ -- to type constructors as we're much more likely to
+ -- actually want anchors to regular definitions than
+ -- type constructor names (such as in #253). So now we
+ -- only get type constructor links if they are actually
+ -- in scope.
+ a : _ -> outOfScope dflags a
+
+ -- There is only one name in the environment that matches so
+ -- use it.
+ [a] -> DocIdentifier a
+ -- But when there are multiple names available, default to
+ -- type constructors: somewhat awfully GHC returns the
+ -- values in the list positionally.
+ a : b : _ | isTyConName a -> DocIdentifier a
+ | otherwise -> DocIdentifier b
+
+ DocWarning doc -> DocWarning (rn doc)
+ DocEmphasis doc -> DocEmphasis (rn doc)
+ DocBold doc -> DocBold (rn doc)
+ DocMonospaced doc -> DocMonospaced (rn doc)
+ DocUnorderedList docs -> DocUnorderedList (map rn docs)
+ DocOrderedList docs -> DocOrderedList (map rn docs)
+ DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ]
+ DocCodeBlock doc -> DocCodeBlock (rn doc)
+ DocIdentifierUnchecked x -> DocIdentifierUnchecked x
+ DocModule modLink -> DocModule (rn <$> modLink)
+ DocHyperlink hyperLink -> DocHyperlink (rn <$> hyperLink)
+ DocPic str -> DocPic str
+ DocMathInline str -> DocMathInline str
+ DocMathDisplay str -> DocMathDisplay str
+ DocAName str -> DocAName str
+ DocProperty p -> DocProperty p
+ DocExamples e -> DocExamples e
+ DocEmpty -> DocEmpty
+ DocString str -> DocString str
+ DocHeader (Header l t) -> DocHeader $ Header l (rn t)
+ DocTable t -> DocTable (rn <$> t)
-- | Wrap an identifier that's out of scope (i.e. wasn't found in
-- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently
@@ -1144,26 +1061,25 @@ rename dflags gre = rn
-- #253 and #375 on the confusion this causes depending on which
-- default we pick in 'rename'.
outOfScope :: DynFlags -> RdrName -> Doc a
-outOfScope dflags x =
- case x of
- Unqual occ -> monospaced occ
- Qual mdl occ -> DocIdentifierUnchecked (mdl, occ)
- Orig _ occ -> monospaced occ
- Exact name -> monospaced name -- Shouldn't happen since x is out of scope
- where
- monospaced :: (Outputable a) => a -> Doc b
- monospaced a = DocMonospaced (DocString (showPpr dflags a))
+outOfScope dflags x = case x of
+ Unqual occ -> monospaced occ
+ Qual mdl occ -> DocIdentifierUnchecked (mdl, occ)
+ Orig _ occ -> monospaced occ
+ Exact name -> monospaced name -- Shouldn't happen since x is out of scope
+ where
+ monospaced :: (Outputable a) => a -> Doc b
+ monospaced a = DocMonospaced (DocString (showPpr dflags a))
makeAnchorId :: String -> String
-makeAnchorId [] = []
-makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
- where
- escape p c | p c = [c]
- | otherwise = '-' : show (ord c) ++ "-"
- isLegal ':' = True
- isLegal '_' = True
- isLegal '.' = True
- isLegal c = isAscii c && isAlphaNum c
+makeAnchorId [] = []
+makeAnchorId (f : r) = escape isAlpha f ++ concatMap (escape isLegal) r
+ where
+ escape p c | p c = [c]
+ | otherwise = '-' : show (ord c) ++ "-"
+ isLegal ':' = True
+ isLegal '_' = True
+ isLegal '.' = True
+ isLegal c = isAscii c && isAlphaNum c
ghcDL :: GHC.Located a -> GHC.Located a
ghcDL x = x
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'))
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-30 08:25:37 +0000