aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authoralexwl <alexey.a.kiryushin@gmail.com>2018-10-02 13:17:04 +0300
committeralexwl <alexey.a.kiryushin@gmail.com>2018-10-02 13:17:04 +0300
commitcf2c56c7061b7ed40fdd3b40a352ddb9c9b7371f (patch)
treeb1de9ada0f1b1cb064e3a9e0d4042d1f519085bd /src
Initial commit
Diffstat (limited to 'src')
-rw-r--r--src/HaskellCodeExplorer/AST/RenamedSource.hs498
-rw-r--r--src/HaskellCodeExplorer/AST/TypecheckedSource.hs1231
-rw-r--r--src/HaskellCodeExplorer/GhcUtils.hs1122
-rw-r--r--src/HaskellCodeExplorer/ModuleInfo.hs811
-rw-r--r--src/HaskellCodeExplorer/PackageInfo.hs595
-rw-r--r--src/HaskellCodeExplorer/Preprocessor.hs159
-rw-r--r--src/HaskellCodeExplorer/Types.hs880
7 files changed, 5296 insertions, 0 deletions
diff --git a/src/HaskellCodeExplorer/AST/RenamedSource.hs b/src/HaskellCodeExplorer/AST/RenamedSource.hs
new file mode 100644
index 0000000..c1bf463
--- /dev/null
+++ b/src/HaskellCodeExplorer/AST/RenamedSource.hs
@@ -0,0 +1,498 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StrictData #-}
+
+module HaskellCodeExplorer.AST.RenamedSource
+ ( NameOccurrence(..)
+ , namesFromRenamedSource
+ ) where
+
+import BasicTypes (TupleSort(..))
+import BooleanFormula (BooleanFormula(..))
+import Data.Generics (Data, everything, extQ, mkQ)
+import Data.Maybe (Maybe(..), mapMaybe)
+import qualified Data.Text as T (Text)
+import GHC
+ ( AmbiguousFieldOcc(..)
+ , ConDecl(..)
+ , ConDeclField(..)
+ , DataFamInstDecl(..)
+ , FamilyDecl(..)
+ , FieldOcc(..)
+ , FixitySig(..)
+ , ForeignDecl(..)
+ , GenLocated(..)
+ , HsBindLR(..)
+ , HsExpr(..)
+ , HsPatSynDetails(..)
+ , HsRecField'(..)
+ , HsTupleSort(..)
+ , HsTyLit(..)
+ , HsTyPats
+ , HsTyVarBndr(..)
+ , HsType(..)
+ , IE(..)
+ , LHsBindLR
+ , LHsExpr
+ , LHsQTyVars(..)
+ , LHsType
+ , LPat
+ , LSig
+ , LTyClDecl
+ , Located
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ , HsMatchContext(..)
+ , Match(..)
+#else
+ , m_fixity
+ , MatchFixity(..)
+#endif
+ , MatchGroup(..)
+ , Name
+ , Pat(..)
+ , PatSynBind(..)
+ , Sig(..)
+ , TyClDecl(..)
+ , TyFamEqn(..)
+ , Type
+ , unLoc
+ )
+import HaskellCodeExplorer.GhcUtils (hsPatSynDetails, ieLocNames)
+import Prelude hiding (span)
+import TysWiredIn
+ ( nilDataConName
+ , tupleTyConName
+ , typeNatKind
+ , typeSymbolKind
+ )
+data NameOccurrence
+ = NameOccurrence { locatedName :: Located (Maybe Name)
+ , description :: T.Text
+ , isBinder :: Bool }
+ | TyLitOccurrence { locatedName :: Located (Maybe Name)
+ , description :: T.Text
+ , kind :: Type }
+
+-- | 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`
+ tyFamilyEqNames `extQ`
+ tyFamilyDefEqNames `extQ`
+ dataFamInstDeclNames `extQ`
+ conDeclNames `extQ`
+ importNames `extQ`
+ hsTyVarBndrNames `extQ`
+ hsPatSynDetailsNames `extQ`
+ conDeclFieldNames `extQ`
+ hsRecFieldExprNames `extQ`
+ hsRecAmbFieldExprNames `extQ`
+ hsRecFieldPatNames `extQ`
+ foreignDeclNames)
+
+fieldOccName :: Bool -> FieldOcc Name -> NameOccurrence
+fieldOccName isBinder (FieldOcc (L span _) name) =
+ NameOccurrence
+ { locatedName = L span (Just name)
+ , description = "FieldOcc"
+ , isBinder = isBinder
+ }
+
+conDeclFieldNames :: ConDeclField Name -> [NameOccurrence]
+conDeclFieldNames ConDeclField {..} =
+ map (fieldOccName True . unLoc) cd_fld_names
+
+hsRecFieldExprNames ::
+ HsRecField' (FieldOcc Name) (LHsExpr Name) -> [NameOccurrence]
+hsRecFieldExprNames HsRecField {..} = [fieldOccName False $ unLoc hsRecFieldLbl]
+
+hsRecAmbFieldExprNames ::
+ HsRecField' (AmbiguousFieldOcc Name) (LHsExpr Name) -> [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
+ }
+ ]
+
+hsRecFieldPatNames ::
+ HsRecField' (FieldOcc Name) (LPat Name) -> [NameOccurrence]
+hsRecFieldPatNames HsRecField {..} = [fieldOccName False $ unLoc hsRecFieldLbl]
+
+hsExprNames :: LHsExpr Name -> [NameOccurrence]
+hsExprNames (L _span (HsVar name)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "HsVar"
+ , isBinder = False
+ }
+ ]
+hsExprNames (L span (ExplicitList _ _ exprs))
+ | null exprs =
+ [ NameOccurrence
+ { locatedName = L span $ Just nilDataConName
+ , description = "ExplicitList"
+ , isBinder = False
+ }
+ ]
+ | otherwise = []
+hsExprNames (L _span (RecordCon name _conLike _instFun _binds)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "RecordCon"
+ , isBinder = False
+ }
+ ]
+hsExprNames (L _span (HsRecFld (Unambiguous (L span _) name))) =
+ [ NameOccurrence
+ { locatedName = L span (Just name)
+ , description = "HsRecFld"
+ , isBinder = False
+ }
+ ]
+hsExprNames (L _span (HsRecFld (Ambiguous (L span _) _name))) =
+ [ NameOccurrence
+ { locatedName = L span Nothing
+ , description = "HsRecFld"
+ , isBinder = False
+ }
+ ]
+hsExprNames _ = []
+
+matchGroupNames :: MatchGroup Name (LHsExpr Name) -> [NameOccurrence]
+matchGroupNames =
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ mapMaybe (fmap toNameOcc . matchContextName . m_ctxt . unLoc) .
+#else
+ mapMaybe (fmap toNameOcc . matchFixityName . m_fixity . unLoc) .
+#endif
+ unLoc . mg_alts
+ where
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ matchContextName :: HsMatchContext Name -> Maybe (Located Name)
+ matchContextName (FunRhs name _ _bool) = Just name
+ matchContextName _ = Nothing
+#else
+ matchFixityName :: MatchFixity Name -> Maybe (Located Name)
+ matchFixityName NonFunBindMatch = Nothing
+ matchFixityName (FunBindMatch name _bool) = Just name
+#endif
+ toNameOcc :: Located Name -> NameOccurrence
+ toNameOcc n =
+ NameOccurrence
+ {locatedName = Just <$> n, description = "Match", isBinder = True}
+
+bindNames :: LHsBindLR Name Name -> [NameOccurrence]
+bindNames (L _span (PatSynBind PSB {..})) =
+ [ NameOccurrence
+ { locatedName = Just <$> psb_id
+ , description = "PatSynBind"
+ , isBinder = True
+ }
+ ]
+bindNames _ = []
+
+hsPatSynDetailsNames :: HsPatSynDetails (Located Name) -> [NameOccurrence]
+hsPatSynDetailsNames =
+ map
+ (\name ->
+ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "HsPatSynDetails"
+ , isBinder = True
+ }) .
+ hsPatSynDetails
+
+importNames :: IE Name -> [NameOccurrence]
+importNames =
+ map
+ (\name ->
+ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "IE"
+ , isBinder = False
+ }) .
+ ieLocNames
+
+patNames :: LPat Name -> [NameOccurrence]
+patNames (L _span (VarPat name)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "VarPat"
+ , isBinder = True
+ }
+ ]
+patNames (L _span (ConPatIn name _)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "ConPatIn"
+ , isBinder = False
+ }
+ ]
+patNames (L _span (AsPat name _)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "AsPat"
+ , isBinder = True
+ }
+ ]
+patNames (L _span (NPlusKPat name _ _ _ _ _)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "NPlusKPat"
+ , isBinder = True
+ }
+ ]
+patNames _ = []
+
+sigNames :: LSig Name -> [NameOccurrence]
+sigNames (L _span (TypeSig names _)) =
+ map
+ (\n ->
+ NameOccurrence
+ { locatedName = Just <$> n
+ , description = "TypeSig"
+ , isBinder = False
+ })
+ names
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+sigNames (L _span (PatSynSig names _)) =
+ map (\name -> NameOccurrence (Just <$> name) "PatSynSig" False) names
+#else
+sigNames (L _span (PatSynSig name _)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "PatSynSig"
+ , isBinder = False
+ }
+ ]
+#endif
+sigNames (L _span (ClassOpSig _ names _)) =
+ map
+ (\n ->
+ NameOccurrence
+ { locatedName = Just <$> n
+ , description = "ClassOpSig"
+ , isBinder = True
+ })
+ names
+sigNames (L _span (FixSig (FixitySig names _))) =
+ map
+ (\n ->
+ NameOccurrence
+ { locatedName = Just <$> n
+ , description = "FixitySig"
+ , isBinder = False
+ })
+ names
+sigNames (L _span (InlineSig name _)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "InlineSig"
+ , isBinder = False
+ }
+ ]
+sigNames (L _span (SpecSig name _ _)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "SpecSig"
+ , isBinder = False
+ }
+ ]
+sigNames (L _span (MinimalSig _ (L _ boolFormula))) =
+ map
+ (\n ->
+ NameOccurrence
+ { locatedName = Just <$> 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 Name -> [NameOccurrence]
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+hsTypeNames (L _span (HsTyVar _promoted name)) =
+#else
+hsTypeNames (L _span (HsTyVar name)) =
+#endif
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "HsTyVar"
+ , isBinder = False
+ }
+ ]
+hsTypeNames (L span (HsTyLit lit)) =
+ let kind =
+ case lit of
+ HsNumTy _ _ -> typeNatKind
+ HsStrTy _ _ -> typeSymbolKind
+ in [ TyLitOccurrence
+ { locatedName = L span Nothing
+ , description = "HsTyLit"
+ , kind = kind
+ }
+ ]
+hsTypeNames (L _span (HsOpTy _ name _)) =
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "HsOpTy"
+ , isBinder = False
+ }
+ ]
+hsTypeNames (L span (HsTupleTy tupleSort types))
+ | null types =
+ let sort =
+ case tupleSort of
+ HsUnboxedTuple -> UnboxedTuple
+ HsBoxedTuple -> BoxedTuple
+ HsConstraintTuple -> ConstraintTuple
+ HsBoxedOrConstraintTuple -> BoxedTuple
+ in [ NameOccurrence
+ { locatedName = L span (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)) = ...
+hsTypeNames _ = []
+
+hsTyVarBndrNames :: HsTyVarBndr Name -> [NameOccurrence]
+hsTyVarBndrNames (UserTyVar n) =
+ [ NameOccurrence
+ { locatedName = Just <$> n
+ , description = "UserTyVar"
+ , isBinder = True
+ }
+ ]
+hsTyVarBndrNames (KindedTyVar n _) =
+ [ NameOccurrence
+ { locatedName = Just <$> n
+ , description = "KindedTyVar"
+ , isBinder = True
+ }
+ ]
+
+tyClDeclNames :: LTyClDecl Name -> [NameOccurrence]
+tyClDeclNames (L _span DataDecl {..}) =
+ [ NameOccurrence
+ { locatedName = Just <$> tcdLName
+ , description = "DataDecl"
+ , isBinder = True
+ }
+ ]
+tyClDeclNames (L _span SynDecl {..}) =
+ [ NameOccurrence
+ { locatedName = Just <$> tcdLName
+ , description = "SynDecl"
+ , isBinder = True
+ }
+ ]
+tyClDeclNames (L _span ClassDecl {..}) =
+ NameOccurrence
+ { locatedName = Just <$> tcdLName
+ , description = "ClassDecl"
+ , isBinder = True
+ } :
+ concatMap
+ ((\(names1, names2) -> map toNameOcc names1 ++ map toNameOcc names2) . unLoc)
+ tcdFDs
+ where
+ toNameOcc :: Located Name -> NameOccurrence
+ toNameOcc n =
+ NameOccurrence
+ { locatedName = Just <$> n
+ , description = "FunDep"
+ , isBinder = False
+ }
+tyClDeclNames _ = []
+
+familyDeclNames :: FamilyDecl Name -> [NameOccurrence]
+familyDeclNames FamilyDecl {..} =
+ [ NameOccurrence
+ { locatedName = Just <$> fdLName
+ , description = "FamilyDecl"
+ , isBinder = True
+ }
+ ]
+
+tyFamilyEqNames :: TyFamEqn Name (HsTyPats Name) -> [NameOccurrence]
+tyFamilyEqNames TyFamEqn {tfe_tycon = tyCon} =
+ [ NameOccurrence
+ { locatedName = Just <$> tyCon
+ , description = "TyFamEqn"
+ , isBinder = False
+ }
+ ]
+
+tyFamilyDefEqNames :: TyFamEqn Name (LHsQTyVars Name) -> [NameOccurrence]
+tyFamilyDefEqNames TyFamEqn {tfe_tycon = tyCon} =
+ [ NameOccurrence
+ { locatedName = Just <$> tyCon
+ , description = "TyFamEqn"
+ , isBinder = False
+ }
+ ]
+
+dataFamInstDeclNames :: DataFamInstDecl Name -> [NameOccurrence]
+dataFamInstDeclNames DataFamInstDecl {dfid_tycon = tyCon} =
+ [ NameOccurrence
+ { locatedName = Just <$> tyCon
+ , description = "DataFamInstDecl"
+ , isBinder = False
+ }
+ ]
+
+conDeclNames :: ConDecl Name -> [NameOccurrence]
+conDeclNames con =
+ case con of
+ ConDeclGADT {con_names = names} ->
+ map
+ (\n ->
+ NameOccurrence
+ { locatedName = Just <$> n
+ , description = "ConDeclGADT"
+ , isBinder = True
+ })
+ names
+ ConDeclH98 {con_name = name} ->
+ [ NameOccurrence
+ { locatedName = Just <$> name
+ , description = "ConDeclH98"
+ , isBinder = True
+ }
+ ]
+
+foreignDeclNames :: ForeignDecl Name -> [NameOccurrence]
+foreignDeclNames decl =
+ [ NameOccurrence
+ { locatedName = Just <$> fd_name decl
+ , description = "ForeignDecl"
+ , isBinder = True
+ }
+ ]
diff --git a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
new file mode 100644
index 0000000..f97c33b
--- /dev/null
+++ b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs
@@ -0,0 +1,1231 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StrictData #-}
+
+module HaskellCodeExplorer.AST.TypecheckedSource
+ ( ASTState(..)
+ , Environment(..)
+ , TypeError(..)
+ , foldTypecheckedSource
+ , mkIdentifierInfo
+ , mkIdentifierOccurrence
+ , mkType
+ , removeOverlappingInterval
+ ) where
+
+import Bag (bagToList)
+import BasicTypes (Origin(..))
+import Class (Class, classTyVars)
+import ConLike (ConLike(..),conLikeWrapId_maybe)
+import Control.Monad (return, unless, void)
+import Control.Monad.State.Strict (State, get, modify')
+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 (Maybe, fromMaybe, mapMaybe)
+import qualified Data.Set as S
+import qualified Data.Text as T
+import DataCon (dataConWorkId)
+import DynFlags (DynFlags)
+import FastString (mkFastString)
+import HaskellCodeExplorer.GhcUtils
+import qualified HaskellCodeExplorer.Types as HCE
+import HsBinds (HsPatSynDetails(..), RecordPatSynField(..))
+import HsSyn
+ ( ABExport(..)
+ , ApplicativeArg(..)
+ , ArithSeqInfo(..)
+ , FieldOcc(..)
+ , GRHS(..)
+ , GRHSs(..)
+ , HsBindLR(..)
+ , HsCmd(..)
+ , HsCmdTop(..)
+ , HsConDetails(..)
+ , HsConPatDetails
+ , HsExpr(..)
+ , HsLocalBindsLR(..)
+ , HsOverLit(..)
+ , HsRecField'(..)
+ , HsRecFields(..)
+ , HsTupArg(..)
+ , HsValBindsLR(..)
+ , HsValBindsLR(..)
+ , LGRHS
+ , LHsBindLR
+ , LHsBinds
+ , LHsCmd
+ , LHsCmd
+ , LHsCmdTop
+ , LHsExpr
+ , LHsRecField
+ , LHsRecUpdField
+ , LHsTupArg
+ , LMatch
+ , LPat
+ , LStmtLR
+ , Match(..)
+ , Match(..)
+ , MatchGroup(..)
+ , ParStmtBlock(..)
+ , Pat(..)
+ , PatSynBind(..)
+ , StmtLR(..)
+ , selectorAmbiguousFieldOcc
+ )
+import HscTypes (TypeEnv, lookupTypeEnv)
+import Id (idType)
+import IdInfo (IdDetails(..))
+import InstEnv
+ ( ClsInst(..)
+ , InstEnvs
+ , instanceSig
+ , is_dfun
+ , lookupUniqueInstEnv
+ )
+import Name (Name, nameOccName, nameUnique)
+import Prelude hiding (span)
+import SrcLoc (GenLocated(..), SrcSpan(..), isGoodSrcSpan, isOneLineSpan, unLoc)
+import TcEvidence (HsWrapper(..))
+import TcHsSyn (conLikeResTy, hsLitType)
+import Type
+ ( TyThing(..)
+ , Type
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ , nonDetCmpTypes
+#else
+ , cmpTypes
+#endif
+ , eqTypes
+ , eqType
+ , getClassPredTys_maybe
+ , mkFunTy
+ , mkFunTys
+ , splitForAllTys
+ , splitFunTy_maybe
+ , splitFunTys
+ , substTys
+ , tidyOpenType
+ , zipTvSubst
+ )
+import TysWiredIn (mkListTy, mkTupleTy)
+import Unique (getKey)
+import Var (Id, Var, idDetails, isId, setVarName, setVarType, varName, varType)
+import VarEnv (TidyEnv)
+
+data ASTState = ASTState
+ { astStateExprInfoMap :: !HCE.ExpressionInfoMap
+ -- ^ Type of each expression
+ , 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'
+ -- and 'IdentifierInfoMap'.
+ -- '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
+ -- ^ 'TidyEnv' is used to prevent name clashes of free type variables.
+ -- ('TidyEnv' contains all free type variables in scope)
+ , astStateHsWrapper :: !(Maybe HsWrapper)
+ -- ^ HsWrapper comes from 'HsWrap' constructor of 'HsExpr' datatype.
+ , astStateEnv :: !Environment
+ -- ^ 'Environment' doesn't change
+ , 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
+ , typeErrorASTNodeName :: T.Text
+ } deriving (Show, Eq)
+
+data Environment = Environment
+ { envDynFlags :: DynFlags
+ , 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)
+ , envExportedNames :: S.Set Name
+ , envComponentId :: HCE.ComponentId
+ }
+
+-- | Indicates whether an expression consists of more than one token.
+-- Simple expression : wildcard, literal
+-- Composite expressin : applcation, lambda abstraction,...
+data ExprSort
+ = Simple
+ | Composite
+ deriving (Show, Eq)
+
+exprSort :: HsExpr a -> ExprSort
+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 _ = Composite
+
+patSort :: Pat a -> ExprSort
+patSort (WildPat _typ) = Simple
+patSort (LitPat _lit) = 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
+
+-- | 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 astNode typ = do
+ tys <- splitFunTySafe srcSpan astNode typ
+ case tys of
+ Just (arg1, ty1) -> do
+ res <- splitFunTySafe srcSpan astNode ty1
+ case res of
+ Just (arg2, ty2) -> return $ Just (arg1, arg2, ty2)
+ Nothing -> return Nothing
+ Nothing -> return Nothing
+
+-- | Returns result type of a function, adds 'TypeError' to
+-- 'ASTState' in case of a failure.
+funResultTySafe :: SrcSpan -> T.Text -> Type -> State ASTState (Maybe Type)
+funResultTySafe srcSpan astNode typ =
+ fmap snd <$> splitFunTySafe srcSpan astNode typ
+
+-- | Returns result type of a function of two arguments,
+-- adds 'TypeError' to 'ASTState' in case of a failure.
+funResultTy2Safe :: SrcSpan -> T.Text -> Type -> State ASTState (Maybe Type)
+funResultTy2Safe srcSpan astNode typ = do
+ mbResTy1 <- funResultTySafe srcSpan astNode typ
+ case mbResTy1 of
+ Just resTy1 -> funResultTySafe srcSpan astNode resTy1
+ Nothing -> return Nothing
+
+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
+-- on 'ExprSort'.
+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
+ mbHsWrapper <- astStateHsWrapper <$> get
+ modify' $ \astState@ASTState {astStateExprInfoMap = exprInfoMap} ->
+ case sort of
+ Composite ->
+ 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'}
+ 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}
+ 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 _ intervals = intervals
+
+newtype InstTypes = InstTypes [Type]
+
+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
+ -> 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
+ 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
+ flags
+ (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
+ currentPackageId = envPackageId environment
+ compId = envComponentId environment
+ transformation = envTransformation environment
+ fileMap = envFileMap environment
+ defSiteMap = envDefSiteMap environment
+ locationInfo =
+ nameLocationInfo
+ flags
+ 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
+ }
+
+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
+ ClassOpId cls -> Just cls
+ _ -> 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)
+
+restoreTidyEnv :: (State ASTState) a -> (State ASTState) a
+restoreTidyEnv action = do
+ tidyEnv <- astStateTidyEnv <$> get
+ res <- action
+ modify' $ \s -> s {astStateTidyEnv = tidyEnv}
+ return res
+
+restoreHsWrapper :: (State ASTState) a -> (State ASTState) a
+restoreHsWrapper action = do
+ wrapper <- astStateHsWrapper <$> get
+ res <- action
+ modify' $ \s -> s {astStateHsWrapper = wrapper}
+ return res
+
+tidyIdentifier :: Id -> State ASTState (Id, Maybe (Type, [Type]))
+tidyIdentifier identifier = do
+ tidyEnv <- astStateTidyEnv <$> get
+ 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})
+ 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'})
+ return typ'
+
+foldTypecheckedSource :: LHsBinds Id -> State ASTState ()
+foldTypecheckedSource = foldLHsBindsLR
+
+foldLHsExpr :: LHsExpr Var -> State ASTState (Maybe Type)
+foldLHsExpr (L span (HsVar (L _ identifier))) =
+ restoreTidyEnv $ do
+ (identifier', mbTypes) <- tidyIdentifier identifier
+ addIdentifierToIdSrcSpanMap span identifier' mbTypes
+ return . Just . varType $ identifier'
+foldLHsExpr (L _ (HsUnboundVar _)) = return Nothing
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+foldLHsExpr (L _ (HsConLikeOut conLike)) =
+ restoreTidyEnv $ do
+ let mbType = varType <$> conLikeWrapId_maybe conLike
+ mbType' <- maybe (return Nothing) (fmap Just . tidyType) mbType
+ return mbType'
+#endif
+foldLHsExpr (L _ (HsRecFld _)) = return Nothing
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+foldLHsExpr (L _ (HsOverLabel _ _)) = return Nothing
+#else
+foldLHsExpr (L _ (HsOverLabel _)) = return Nothing
+#endif
+foldLHsExpr (L span expr@(HsIPVar _)) = do
+ addExprInfo span Nothing "HsIPVar" (exprSort expr)
+ return Nothing
+foldLHsExpr (L span (HsOverLit OverLit {ol_type})) =
+ restoreTidyEnv $ do
+ typ <- tidyType ol_type
+ addExprInfo
+ span
+ (Just typ)
+ "HsOverLit"
+ (if isOneLineSpan span
+ then Simple
+ else Composite)
+ return $ Just typ
+foldLHsExpr (L span (HsLit lit)) =
+ restoreTidyEnv $ do
+ typ <- tidyType $ hsLitType lit
+ addExprInfo
+ span
+ (Just typ)
+ "HsLit"
+ (if isOneLineSpan span
+ then Simple
+ else Composite)
+ return $ Just typ
+foldLHsExpr (L span expr@(HsLam MG {..})) =
+ restoreTidyEnv $ do
+ typ <- tidyType $ mkFunTys mg_arg_tys mg_res_ty
+ addExprInfo span (Just typ) "HsLam" (exprSort expr)
+ mapM_ foldLMatch $ unLoc mg_alts
+ return $ Just typ
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+foldLHsExpr (L span expr@(HsLamCase MG {..})) =
+#else
+foldLHsExpr (L span expr@(HsLamCase _typ MG {..})) =
+#endif
+ restoreTidyEnv $ do
+ typ <- tidyType $ mkFunTys mg_arg_tys mg_res_ty
+ addExprInfo span (Just typ) "HsLamCase" (exprSort expr)
+ mapM_ foldLMatch $ unLoc mg_alts
+ return $ Just typ
+foldLHsExpr (L span expr@(HsApp fun arg)) = do
+ funTy <- foldLHsExpr fun
+ _argTy <- foldLHsExpr arg
+ typ <- fromMaybe (return Nothing) (funResultTySafe span "HsApp" <$> funTy)
+ addExprInfo span typ "HsApp" (exprSort expr)
+ return typ
+foldLHsExpr (L _ (HsAppType _ _)) = return Nothing
+foldLHsExpr (L span ex@(HsAppTypeOut expr _)) = do
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "HsAppTypeOut" (exprSort ex)
+ return typ
+foldLHsExpr (L span expr@(OpApp left op _fixity right)) = do
+ opTyp <- foldLHsExpr op
+ typ <- fromMaybe (return Nothing) (funResultTy2Safe span "HsApp" <$> opTyp)
+ _ <- foldLHsExpr left
+ _ <- foldLHsExpr right
+ addExprInfo span typ "OpApp" (exprSort expr)
+ return typ
+foldLHsExpr (L span e@(NegApp expr _syntaxExp)) = do
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "NegApp" (exprSort e)
+ return typ
+foldLHsExpr (L _span (HsPar expr)) = foldLHsExpr expr
+foldLHsExpr (L span expr@(SectionL operand operator)) = do
+ opType <- foldLHsExpr operator
+ _ <- foldLHsExpr operand
+ mbTypes <-
+ fromMaybe (return Nothing) (splitFunTy2Safe span "SectionL" <$> opType)
+ let typ =
+ case mbTypes of
+ Just (_arg1, arg2, res) -> Just $ mkFunTy arg2 res
+ Nothing -> Nothing
+ addExprInfo span typ "SectionL" (exprSort expr)
+ return typ
+foldLHsExpr (L span e@(SectionR operator operand)) = do
+ opType <- foldLHsExpr operator
+ _ <- foldLHsExpr operand
+ mbTypes <-
+ fromMaybe (return Nothing) (splitFunTy2Safe span "SectionR" <$> opType)
+ let typ =
+ case mbTypes of
+ Just (arg1, _arg2, res) -> Just $ mkFunTy arg1 res
+ Nothing -> Nothing
+ addExprInfo span typ "SectionR" (exprSort e)
+ return typ
+foldLHsExpr (L span e@(ExplicitTuple tupArgs boxity)) = do
+ tupleArgs <- mapM foldLHsTupArg tupArgs
+ let tupleSectionArgTys =
+ mapM fst . filter ((== TupArgMissing) . snd) $ tupleArgs
+ tupleArgTys = mapM fst tupleArgs
+ resultType =
+ mkFunTys <$> tupleSectionArgTys <*> (mkTupleTy boxity <$> tupleArgTys)
+ tidyEnv <- astStateTidyEnv <$> get
+ addExprInfo
+ span
+ ((snd . tidyOpenType tidyEnv) <$> resultType)
+ "ExplicitTuple"
+ (exprSort e)
+ return resultType
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+foldLHsExpr (L _span (ExplicitSum _ _ expr _types)) = do
+ -- TODO
+ _ <- foldLHsExpr expr
+ return Nothing
+#endif
+foldLHsExpr (L span e@(HsCase expr MG {..})) =
+ restoreTidyEnv $ do
+ typ <- tidyType mg_res_ty
+ _ <- foldLHsExpr expr
+ mapM_ foldLMatch (unLoc mg_alts)
+ addExprInfo span (Just typ) "HsCase" (exprSort e)
+ return $ Just typ
+foldLHsExpr (L span e@(HsIf _mbSynExpr condExpr thenExpr elseExpr)) = do
+ _ <- foldLHsExpr condExpr
+ typ <- foldLHsExpr thenExpr
+ _ <- foldLHsExpr elseExpr
+ addExprInfo span typ "HsIf" (exprSort e)
+ return typ
+foldLHsExpr (L span e@(HsMultiIf typ grhss)) =
+ restoreTidyEnv $ do
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "HsMultiIf" (exprSort e)
+ mapM_ foldLGRHS grhss
+ return $ Just typ'
+foldLHsExpr (L span e@(HsLet (L _ binds) expr)) = do
+ _ <- foldHsLocalBindsLR binds
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "HsLet" (exprSort e)
+ return typ
+foldLHsExpr (L span expr@(HsDo _context (L _ stmts) typ)) =
+ restoreTidyEnv $ do
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "HsDo" (exprSort expr)
+ mapM_ foldLStmtLR stmts
+ return $ Just typ'
+foldLHsExpr (L span (ExplicitList typ _syntaxExpr exprs)) =
+ restoreTidyEnv $ do
+ typ' <- mkListTy <$> tidyType typ
+ unless (null exprs) $ addExprInfo span (Just typ') "ExplicitList" Composite
+ mapM_ foldLHsExpr exprs
+ return $ Just typ'
+foldLHsExpr (L span e@(ExplicitPArr typ exprs)) =
+ restoreTidyEnv $ do
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "ExplicitPArr" (exprSort e)
+ mapM_ foldLHsExpr exprs
+ return $ Just typ'
+foldLHsExpr (L span e@(RecordCon (L _ _) _conLike conExpr binds)) = do
+ mbConType <-
+ fmap (snd . splitFunTys) <$>
+ foldLHsExpr (L (UnhelpfulSpan $ mkFastString "RecordCon") conExpr)
+ addExprInfo span mbConType "RecordCon" (exprSort e)
+ _ <- foldHsRecFields binds
+ return mbConType
+foldLHsExpr (L span e@(RecordUpd expr binds cons _inputTys outTys _wrapper)) =
+ 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
+ addExprInfo span (Just typ') "RecordUpd" (exprSort e)
+ _ <- foldLHsExpr expr
+ mapM_ foldLHsRecUpdField binds
+ return $ Just typ'
+foldLHsExpr (L _span (ExprWithTySig _expr _type)) = return Nothing
+foldLHsExpr (L span e@(ExprWithTySigOut expr _type)) = do
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "ExprWithTySigOut" (exprSort e)
+ return typ
+foldLHsExpr (L span e@(ArithSeq postTcExpr _mbSyntaxExpr seqInfo)) = do
+ typ <-
+ fmap (snd . splitFunTys . snd . splitForAllTys) <$>
+ foldLHsExpr (L (UnhelpfulSpan $ 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 span typ "ArithSeq" (exprSort e)
+ return typ
+foldLHsExpr (L span e@(PArrSeq postTcExpr _seqInfo)) = do
+ typ <- foldLHsExpr (L (UnhelpfulSpan $ mkFastString "PArrSeq") postTcExpr)
+ addExprInfo span typ "ArithSeq" (exprSort e)
+ return typ
+foldLHsExpr (L span e@(HsSCC _sourceText _fastString expr)) = do
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "HsSCC" (exprSort e)
+ return typ
+foldLHsExpr (L span e@(HsCoreAnn _sourceText _fastString expr)) = do
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "HsCoreAnn" (exprSort e)
+ return typ
+foldLHsExpr (L _span (HsBracket _bracket)) = return Nothing
+foldLHsExpr (L _span (HsRnBracketOut _ _)) = return Nothing
+foldLHsExpr (L _span (HsTcBracketOut _bracket _splice)) = return Nothing
+foldLHsExpr (L _span (HsSpliceE _)) = return Nothing
+foldLHsExpr (L span expr@(HsProc pat cmd)) = do
+ _ <- foldLPat pat
+ _ <- foldLHsCmdTop cmd
+ addExprInfo span Nothing "HsProc" (exprSort expr)
+ return Nothing
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+foldLHsExpr (L span e@(HsStatic _ expr)) = do
+#else
+foldLHsExpr (L span e@(HsStatic expr)) = do
+#endif
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "HsStatic" (exprSort e)
+ return typ
+foldLHsExpr (L _ HsArrForm {}) = return Nothing
+foldLHsExpr (L _ HsArrApp {}) = return Nothing
+foldLHsExpr (L span e@(HsTick _ expr)) = do
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "HsTick" (exprSort e)
+ return typ
+foldLHsExpr (L span e@(HsBinTick _ _ expr)) = do
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "HsBinTick" (exprSort e)
+ return typ
+foldLHsExpr (L span e@(HsTickPragma _ _ _ expr)) = do
+ typ <- foldLHsExpr expr
+ addExprInfo span typ "HsTickPragma" (exprSort e)
+ return typ
+foldLHsExpr (L _span EWildPat) = return Nothing
+foldLHsExpr (L _span (EAsPat _ _)) = return Nothing
+foldLHsExpr (L _span (EViewPat _ _)) = return Nothing
+foldLHsExpr (L _span (ELazyPat _)) = return Nothing
+foldLHsExpr (L span (HsWrap wrapper expr)) =
+ restoreHsWrapper $ do
+ case exprSort expr of
+ Simple -> modify' (\s -> s {astStateHsWrapper = Just wrapper})
+ Composite -> return () -- Not sure if it is possible
+ typ <- foldLHsExpr (L span expr)
+ return $ applyWrapper wrapper <$> typ
+
+foldHsRecFields :: HsRecFields Id (LHsExpr Id) -> State ASTState (Maybe Type)
+foldHsRecFields HsRecFields {..} = do
+ let userWritten =
+ case rec_dotdot of
+ Just i -> take i
+ Nothing -> id
+ mapM_ foldLHsRecField $ userWritten rec_flds
+ return Nothing
+
+foldLHsRecField :: LHsRecField Id (LHsExpr Id) -> State ASTState (Maybe Type)
+foldLHsRecField (L span (HsRecField (L idSpan (FieldOcc _ identifier)) arg pun)) =
+ restoreTidyEnv $ do
+ (identifier', mbTypes) <- tidyIdentifier identifier
+ addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes
+ addExprInfo span (Just . varType $ identifier') "HsRecField" Composite
+ unless pun $ void (foldLHsExpr arg)
+ return . Just . varType $ identifier'
+
+foldLHsRecUpdField :: LHsRecUpdField Id -> State ASTState (Maybe Type)
+foldLHsRecUpdField (L span (HsRecField (L idSpan recField) arg pun)) =
+ restoreTidyEnv $ do
+ let selectorId = selectorAmbiguousFieldOcc recField
+ (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
+ let identifier'' = setVarName identifier' originalName
+ addIdentifierToIdSrcSpanMap idSpan identifier'' mbTypes
+ addExprInfo span (Just . varType $ identifier'') "HsRecUpdField" Composite
+ unless pun $ void (foldLHsExpr arg)
+ return . Just . varType $ identifier'
+
+data TupArg
+ = TupArgPresent
+ | TupArgMissing
+ deriving (Show, Eq)
+
+foldLHsTupArg :: LHsTupArg Id -> State ASTState (Maybe Type, TupArg)
+foldLHsTupArg (L _span (Present expr)) =
+ restoreTidyEnv $ do
+ typ <- foldLHsExpr expr
+ typ' <-
+ case typ of
+ Just t -> Just <$> tidyType t
+ Nothing -> return Nothing
+ return (typ', TupArgPresent)
+foldLHsTupArg (L _ (Missing typ)) =
+ restoreTidyEnv $ do
+ typ' <- tidyType typ
+ return (Just typ', TupArgMissing)
+
+foldLMatch :: LMatch Id (LHsExpr Var) -> State ASTState (Maybe Type)
+foldLMatch (L _span Match {..}) = do
+ mapM_ foldLPat m_pats
+ _ <- foldGRHSs m_grhss
+ return Nothing
+
+foldLMatchCmd :: LMatch Id (LHsCmd Var) -> State ASTState (Maybe Type)
+foldLMatchCmd (L _span Match {..}) = do
+ mapM_ foldLPat m_pats
+ _ <- foldGRHSsCmd m_grhss
+ return Nothing
+
+foldGRHSsCmd :: GRHSs Id (LHsCmd Id) -> State ASTState (Maybe Type)
+foldGRHSsCmd GRHSs {..} = do
+ mapM_ foldLGRHSCmd grhssGRHSs
+ _ <- foldHsLocalBindsLR (unLoc grhssLocalBinds)
+ return Nothing
+
+foldGRHSs :: GRHSs Id (LHsExpr Var) -> State ASTState (Maybe Type)
+foldGRHSs GRHSs {..} = do
+ mapM_ foldLGRHS grhssGRHSs
+ _ <- foldHsLocalBindsLR (unLoc grhssLocalBinds)
+ return Nothing
+
+foldLStmtLR :: LStmtLR Id Id (LHsExpr Var) -> State ASTState (Maybe Type)
+foldLStmtLR (L span (LastStmt body _ _)) =
+ do typ <- foldLHsExpr body
+ addExprInfo span typ "LastStmt" Composite
+ return typ
+foldLStmtLR (L _span (BindStmt pat body _ _ _)) = do
+ _ <- foldLPat pat
+ _ <- foldLHsExpr body
+ return Nothing
+foldLStmtLR (L span (BodyStmt body _ _ _)) = do
+ mbTyp <- foldLHsExpr body
+ addExprInfo span mbTyp "BodyStmt" Composite
+ return mbTyp
+foldLStmtLR (L _ (LetStmt (L _ binds))) = do
+ _ <- foldHsLocalBindsLR binds
+ return Nothing
+foldLStmtLR (L _ (ParStmt blocks _ _ _)) = do
+ mapM_ foldParStmtBlock blocks
+ return Nothing
+foldLStmtLR (L _ TransStmt {..}) = do
+ mapM_ foldLStmtLR trS_stmts
+ _ <- maybe (return Nothing) foldLHsExpr trS_by
+ _ <- foldLHsExpr trS_using
+ return Nothing
+foldLStmtLR (L _span RecStmt {..}) = do
+ mapM_ foldLStmtLR recS_stmts
+ return Nothing
+foldLStmtLR (L span (ApplicativeStmt args _ typ)) =
+ restoreTidyEnv $ do
+ typ' <- tidyType typ
+ mapM_ (foldApplicativeArg . snd) args
+ addExprInfo span (Just typ') "ApplicativeStmt" Composite
+ return Nothing
+
+foldApplicativeArg :: ApplicativeArg Id Id -> State ASTState (Maybe Type)
+foldApplicativeArg appArg =
+ case appArg of
+ ApplicativeArgOne pat expr -> do
+ _ <- foldLPat pat
+ _ <- foldLHsExpr expr
+ return Nothing
+ ApplicativeArgMany exprStmts _ pat -> do
+ _ <- mapM_ foldLStmtLR exprStmts
+ _ <- foldLPat pat
+ return Nothing
+
+foldLStmtLRCmd :: LStmtLR Id Id (LHsCmd Var)
+ -> State ASTState (Maybe Type)
+foldLStmtLRCmd (L span (LastStmt body _syntaxExpr _)) = do
+ typ <- foldLHsCmd body
+ addExprInfo span typ "LastStmt Cmd" Composite
+ return typ
+foldLStmtLRCmd (L _ (BindStmt pat body _ _ _)) = do
+ _ <- foldLPat pat
+ _ <- foldLHsCmd body
+ return Nothing
+foldLStmtLRCmd (L span (BodyStmt body _ _ _)) = do
+ typ <- foldLHsCmd body
+ addExprInfo span typ "BodyStmt Cmd" Composite
+ return typ
+foldLStmtLRCmd (L _ (LetStmt (L _ binds))) = do
+ _ <- foldHsLocalBindsLR binds
+ return Nothing
+foldLStmtLRCmd (L _ (ParStmt blocks _ _ _)) = do
+ mapM_ foldParStmtBlock blocks
+ return Nothing
+foldLStmtLRCmd (L _ TransStmt {..}) = do
+ mapM_ foldLStmtLR trS_stmts
+ _ <- foldLHsExpr trS_using
+ _ <- maybe (return Nothing) foldLHsExpr trS_by
+ return Nothing
+foldLStmtLRCmd (L _ RecStmt {..}) = do
+ mapM_ foldLStmtLRCmd recS_stmts
+ return Nothing
+foldLStmtLRCmd (L span (ApplicativeStmt args _ typ)) =
+ restoreTidyEnv $ do
+ typ' <- tidyType typ
+ mapM_ (foldApplicativeArg . snd) args
+ addExprInfo span (Just typ') "ApplicativeStmt Cmd" Composite
+ return Nothing
+
+foldLGRHS :: LGRHS Id (LHsExpr Id) -> State ASTState (Maybe Type)
+foldLGRHS (L _span (GRHS guards body)) = do
+ typ <- foldLHsExpr body
+ mapM_ foldLStmtLR guards
+ return typ
+
+foldLGRHSCmd :: LGRHS Id (LHsCmd Var) -> State ASTState (Maybe Type)
+foldLGRHSCmd (L _span (GRHS guards body)) = do
+ typ <- foldLHsCmd body
+ mapM_ foldLStmtLR guards
+ return typ
+
+foldParStmtBlock :: ParStmtBlock Id Id -> State ASTState (Maybe Type)
+foldParStmtBlock (ParStmtBlock exprStmts _ids _syntaxExpr) = do
+ mapM_ foldLStmtLR exprStmts
+ return Nothing
+
+foldHsLocalBindsLR :: HsLocalBindsLR Id Id -> State ASTState (Maybe Type)
+foldHsLocalBindsLR (HsValBinds binds) = do
+ _ <- foldHsValBindsLR binds
+ return Nothing
+foldHsLocalBindsLR (HsIPBinds _binds) = return Nothing
+foldHsLocalBindsLR EmptyLocalBinds = return Nothing
+
+foldHsValBindsLR :: HsValBindsLR Id Var -> State ASTState (Maybe Type)
+foldHsValBindsLR (ValBindsIn _ _) = return Nothing
+foldHsValBindsLR (ValBindsOut binds _) = do
+ _ <- mapM_ (foldLHsBindsLR . snd) binds
+ return Nothing
+
+foldLHsBindsLR :: LHsBinds Id -> State ASTState ()
+foldLHsBindsLR = mapM_ (`foldLHsBindLR` Nothing) . bagToList
+
+foldLHsBindLR :: LHsBindLR Id Var
+ -> Maybe Id -- ^ Polymorphic id
+ -> State ASTState (Maybe Type)
+foldLHsBindLR (L _span FunBind {..}) mbPolyId
+ | mg_origin fun_matches == FromSource =
+ restoreTidyEnv $ do
+ let (L idSpan 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 idSpan 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 _ AbsBinds {..}) _ = do
+ _ <-
+ mapM_ (\(bind, typ) -> foldLHsBindLR bind (Just typ)) $
+ zip (bagToList abs_binds) (map abe_poly abs_exports)
+ return Nothing
+foldLHsBindLR (L _ AbsBindsSig {..}) _ = do
+ _ <- foldLHsBindLR abs_sig_bind (Just abs_sig_export)
+ return Nothing
+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
+ InfixPatSyn id1 id2 -> addId id1 >> addId id2
+ PrefixPatSyn ids -> mapM_ addId ids
+ RecordPatSyn recs ->
+ mapM_
+ (\(RecordPatSynField selId patVar) ->
+ addId selId >> addId patVar)
+ recs
+ return Nothing
+
+foldLPat :: LPat Id -> State ASTState (Maybe Type)
+foldLPat (L span (VarPat (L _ identifier))) = do
+ (identifier', _) <- tidyIdentifier identifier
+ addIdentifierToIdSrcSpanMap span identifier' Nothing
+ return . Just . varType $ identifier'
+foldLPat (L span pat@(WildPat typ)) = do
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "WildPat" (patSort pat)
+ return $ Just typ'
+foldLPat (L span p@(LazyPat pat)) = do
+ mbType <- foldLPat pat
+ addExprInfo span mbType "LazyPat" (patSort p)
+ return mbType
+foldLPat (L span p@(AsPat (L idSpan identifier) pat)) = do
+ (identifier', _) <- tidyIdentifier identifier
+ addIdentifierToIdSrcSpanMap idSpan identifier' Nothing
+ addExprInfo span (Just . varType $ identifier') "AsPat" (patSort p)
+ _ <- foldLPat pat
+ return . Just . varType $ identifier'
+foldLPat (L _span (ParPat pat)) = foldLPat pat
+foldLPat (L span p@(BangPat pat)) = do
+ typ <- foldLPat pat
+ addExprInfo span typ "BangPat" (patSort p)
+ return typ
+foldLPat (L span p@(ListPat pats typ _)) = do
+ typ' <- tidyType typ
+ let listType = mkListTy typ'
+ addExprInfo span (Just listType) "ListPat" (patSort p)
+ _ <- mapM_ foldLPat pats
+ return $ Just listType
+foldLPat (L span pat@(TuplePat pats boxity types)) = do
+ typ' <- tidyType $ mkTupleTy boxity types
+ addExprInfo span (Just typ') "TuplePat" (patSort pat)
+ _ <- mapM_ foldLPat pats
+ return $ Just typ'
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+foldLPat (L _span (SumPat pat _ _ _types)) = do
+ -- TODO
+ _ <- foldLPat pat
+ return Nothing
+#endif
+foldLPat (L span pat@(PArrPat pats typ)) = do
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "PArrPat" (patSort pat)
+ _ <- mapM_ foldLPat pats
+ return $ Just typ'
+foldLPat (L _span (ConPatIn _ _)) = return Nothing
+foldLPat (L span pat@ConPatOut {..}) = do
+ let (L idSpan conLike) = pat_con
+ conId =
+ case conLike of
+ RealDataCon dc -> dataConWorkId dc
+ PatSynCon ps -> patSynId ps
+ typ = conLikeResTy (unLoc pat_con) pat_arg_tys
+ (identifier', mbTypes) <- tidyIdentifier conId
+ addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "ConPatOut" (patSort pat)
+ _ <- foldHsConPatDetails pat_args
+ return . Just . varType $ identifier'
+foldLPat (L span p@(ViewPat expr pat typ)) = do
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "ViewPat" (patSort p)
+ _ <- foldLPat pat
+ _ <- foldLHsExpr expr
+ return $ Just typ'
+foldLPat (L _ (SplicePat _)) = return Nothing
+foldLPat (L span (LitPat hsLit)) = do
+ typ' <- tidyType $ hsLitType hsLit
+ addExprInfo
+ span
+ (Just typ')
+ "LitPat"
+ (if isOneLineSpan span
+ then Simple
+ else Composite)
+ return $ Just typ'
+foldLPat (L span pat@(NPat (L _spanLit OverLit {ol_type}) _ _ _)) = do
+ typ' <- tidyType ol_type
+ addExprInfo span (Just typ') "NPat" (patSort pat)
+ return $ Just ol_type
+foldLPat (L span pat@(NPlusKPat (L idSpan identifier) (L litSpan OverLit {ol_type}) _ _ _ typ)) = do
+ (identifier', _) <- tidyIdentifier identifier
+ addIdentifierToIdSrcSpanMap idSpan identifier' Nothing
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "NPlusKPat" (patSort pat)
+ olType' <- tidyType ol_type
+ addExprInfo
+ litSpan
+ (Just olType')
+ "NPlusKPat"
+ (if isOneLineSpan span
+ then Simple
+ else Composite)
+ return $ Just typ'
+foldLPat (L _span (SigPatIn _ _)) = return Nothing
+foldLPat (L _span (SigPatOut pat typ)) = do
+ typ' <- tidyType typ
+ _ <- foldLPat pat
+ return $ Just typ'
+foldLPat (L span p@(CoPat _ pat typ)) = do
+ typ' <- tidyType typ
+ addExprInfo span (Just typ') "CoPat" (patSort p)
+ _ <- foldLPat (L span pat)
+ return Nothing
+
+foldHsConPatDetails
+ :: HsConPatDetails Id
+ -> State ASTState (Maybe Type)
+foldHsConPatDetails (PrefixCon args) = do
+ _ <- mapM_ foldLPat args
+ return Nothing
+foldHsConPatDetails (RecCon rec) = do
+ _ <- foldHsRecFieldsPat rec
+ return Nothing
+foldHsConPatDetails (InfixCon arg1 arg2) = do
+ _ <- foldLPat arg1
+ _ <- foldLPat arg2
+ return Nothing
+
+foldHsRecFieldsPat :: HsRecFields Id (LPat Id) -> State ASTState (Maybe Type)
+foldHsRecFieldsPat HsRecFields {..} = do
+ let onlyUserWritten =
+ case rec_dotdot of
+ Just i -> take i
+ Nothing -> id
+ _ <- mapM_ foldLHsRecFieldPat $ onlyUserWritten rec_flds
+ return Nothing
+
+foldLHsRecFieldPat :: LHsRecField Id (LPat Id) -> State ASTState (Maybe Type)
+foldLHsRecFieldPat (L _ (HsRecField (L idSpan (FieldOcc _ identifier)) arg pun)) = do
+ (identifier', mbTypes) <- tidyIdentifier identifier
+ addIdentifierToIdSrcSpanMap idSpan identifier' mbTypes
+ unless pun $ void $ foldLPat arg
+ return . Just . varType $ identifier'
+
+foldLHsCmdTop :: LHsCmdTop Id -> State ASTState (Maybe Type)
+foldLHsCmdTop (L span (HsCmdTop cmd _ _ _)) = do
+ mbTyp <- foldLHsCmd cmd
+ addExprInfo span mbTyp "HsCmdTop" Composite
+ return mbTyp
+
+foldLHsCmd :: LHsCmd Id -> State ASTState (Maybe Type)
+foldLHsCmd (L _ (HsCmdArrApp expr1 expr2 _ _ _)) = do
+ _ <- foldLHsExpr expr1
+ _ <- foldLHsExpr expr2
+ return Nothing
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+foldLHsCmd (L _ (HsCmdArrForm expr _ _ topCmds)) = do
+#else
+foldLHsCmd (L _ (HsCmdArrForm expr _ topCmds)) = do
+#endif
+ _ <- foldLHsExpr expr
+ _ <- mapM_ foldLHsCmdTop topCmds
+ return Nothing
+foldLHsCmd (L _ (HsCmdApp cmd expr)) = do
+ _ <- foldLHsCmd cmd
+ _ <- foldLHsExpr expr
+ return Nothing
+foldLHsCmd (L _ (HsCmdLam MG {..})) = do
+ mapM_ foldLMatchCmd $ unLoc mg_alts
+ return Nothing
+foldLHsCmd (L _ (HsCmdCase expr MG {..})) = do
+ _ <- foldLHsExpr expr
+ mapM_ foldLMatchCmd $ unLoc mg_alts
+ return Nothing
+foldLHsCmd (L _ (HsCmdPar cmd)) = do
+ _ <- foldLHsCmd cmd
+ return Nothing
+foldLHsCmd (L _ (HsCmdIf _ expr cmd1 cmd2)) = do
+ _ <- foldLHsCmd cmd1
+ _ <- foldLHsCmd cmd2
+ _ <- foldLHsExpr expr
+ return Nothing
+foldLHsCmd (L _ (HsCmdLet (L _ binds) cmd)) = do
+ _ <- foldLHsCmd cmd
+ _ <- foldHsLocalBindsLR binds
+ return Nothing
+foldLHsCmd (L _ (HsCmdDo stmts _)) = do
+ mapM_ foldLStmtLRCmd $ unLoc stmts
+ return Nothing
+foldLHsCmd (L span (HsCmdWrap _ cmd)) = do
+ _ <- foldLHsCmd (L span cmd)
+ return Nothing
diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs
new file mode 100644
index 0000000..714e429
--- /dev/null
+++ b/src/HaskellCodeExplorer/GhcUtils.hs
@@ -0,0 +1,1122 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module HaskellCodeExplorer.GhcUtils
+ ( -- * Pretty-printing
+ toText
+ , instanceToText
+ , instanceDeclToText
+ , nameToText
+ , tyClDeclPrefix
+ , demangleOccName
+ , stringBufferToByteString
+ , nameSort
+ , occNameNameSpace
+ , identifierKey
+ , nameKey
+ , mbIdDetails
+ -- * Syntax manipulation
+ , hsGroupVals
+ , hsPatSynDetails
+ , ieLocNames
+ -- * Lookups
+ , lookupIdInTypeEnv
+ , lookupNameModuleAndPackage
+ -- * Location info
+ , isHsBoot
+ , moduleLocationInfo
+ , nameLocationInfo
+ , occNameLocationInfo
+ , nameDocumentation
+ , srcSpanToLineAndColNumbers
+ -- * Type-related functions
+ , tyThingToId
+ , tidyIdentifierType
+ , patSynId
+ , applyWrapper
+ , wrapperTypes
+ , tyVarsOfType
+ , tyConsOfType
+ , updateOccNames
+ , mkType
+ -- * Documentation processing
+ , collectDocs
+ , ungroup
+ , mkDecls
+ , getMainDeclBinder
+ , classDeclDocs
+ , sigNameNoLoc
+ , clsInstDeclSrcSpan
+ , hsDocsToDocH
+ , subordinateNamesWithDocs
+ ) where
+import Bag (bagToList)
+import ConLike (ConLike(..))
+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.Either (either)
+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 Data.Ord (comparing)
+import qualified Data.Text as T
+import DataCon (dataConWorkId, flSelector)
+import Documentation.Haddock.Parser (overIdentifier, parseParas)
+import Documentation.Haddock.Types (DocH(..), Header(..), _doc)
+import DynFlags ()
+import FastString (mkFastString, unpackFS)
+import GHC
+ ( DynFlags
+ , HsDocString(..)
+ , InstDecl(..)
+ , ModuleName
+ , Name
+ , SrcSpan(..)
+ , RealSrcSpan(..)
+ , ClsInstDecl(..)
+ , TyClDecl(..)
+ , HsDataDefn(..)
+ , NewOrData(..)
+ , Id
+ , HsGroup(..)
+ , HsBindLR(..)
+ , HsValBindsLR(..)
+ , HsPatSynDetails(..)
+ , Located
+ , IE(..)
+ , TyThing(..)
+ , LHsDecl
+ , HsDecl(..)
+ , DocDecl(..)
+ , ConDecl(..)
+ , PostRn
+ , HsConDetails(..)
+ , ConDeclField(..)
+ , DataFamInstDecl(..)
+ , LSig
+ , Sig(..)
+ , ForeignDecl(..)
+ , FixitySig(..)
+ , tcdName
+ , collectHsBindBinders
+ , getLoc
+ , hsSigType
+ , getConNames
+ , getConDetails
+ , selectorFieldOcc
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ , tyClGroupTyClDecls
+ , LIEWrappedName
+ , hsGroupInstDecls
+ , ieLWrappedName
+#else
+ , tyClGroupConcat
+#endif
+ , tyConKind
+ , nameSrcSpan
+ , srcSpanFile
+ , srcSpanStartLine
+ , srcSpanEndLine
+ , srcSpanStartCol
+ , srcSpanEndCol
+ , isExternalName
+ , moduleNameString
+ , recordPatSynSelectorId
+ , recordPatSynPatVar
+ , isGoodSrcSpan
+ , isLocalId
+ , isDataFamilyDecl
+ , tyFamInstDeclName
+ , idType
+ , hsib_body
+ , tfe_pats
+ , tfid_eqn
+ )
+import qualified HaskellCodeExplorer.Types as HCE
+import HscTypes (TypeEnv, lookupTypeEnv)
+import IdInfo (IdDetails(..))
+import InstEnv (ClsInst(..))
+import Lexer (ParseResult(POk), mkPState, unP)
+import Module (Module(..))
+import Name
+ ( isDataConNameSpace
+ , isDerivedOccName
+ , isInternalName
+ , isSystemName
+ , isTvNameSpace
+ , isTyConName
+ , isVarNameSpace
+ , isWiredInName
+ , mkInternalName
+ , mkOccName
+ , nameModule_maybe
+ , nameOccName
+ , nameUnique
+ , occNameFS
+ , occNameSpace
+ , occNameString
+ , wiredInNameTyThing_maybe
+ )
+import OccName (OccName)
+import Outputable (Outputable, ppr, showPpr, showSDoc)
+import PackageConfig (packageVersion)
+import Packages
+ ( LookupResult(..)
+ , lookupModuleWithSuggestions
+ , lookupPackage
+ , packageNameString
+ )
+import Pair (pSnd)
+import Parser (parseIdentifier)
+import PatSyn (PatSyn, patSynMatcher, patSynSig)
+import Prelude hiding (id, span)
+import RdrName (GlobalRdrEnv, RdrName(..), gre_name, lookupGRE_RdrName)
+import RnEnv (dataTcOccs)
+import SrcLoc (GenLocated(..), mkRealSrcLoc, unLoc)
+import StringBuffer (StringBuffer(..), stringToStringBuffer)
+import System.FilePath (normalise)
+import TcEvidence (HsWrapper(..), tcCoercionKind)
+import TcType (evVarPred)
+import TyCoRep (Type(..),
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ ArgFlag(..)
+#else
+ VisibilityFlag(..)
+#endif
+ )
+import TyCon (tyConName)
+import Type
+ ( coreView
+ , expandTypeSynonyms
+ , mkForAllTy
+ , mkFunTy
+ , mkFunTys
+ , mkInvForAllTys
+#if !MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ , mkNamedBinder
+#endif
+ , piResultTy
+ , pprSigmaType
+ , splitFunTy_maybe
+ , tidyOpenType
+ )
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+import ToIface
+import IfaceType
+#endif
+import TysWiredIn (unitTy)
+import UniqSet (emptyUniqSet, unionUniqSets,
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ nonDetEltsUniqSet
+#else
+ uniqSetToList
+#endif
+ )
+import Unique (getKey)
+import Var
+ ( idDetails
+ , isId
+ , mkTyVar
+ , setVarType
+ , varName
+ , varType
+ , varUnique
+ )
+import VarEnv (TidyEnv)
+import VarSet (VarSet, emptyVarSet, unionVarSet, unitVarSet
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+#else
+ ,varSetElems
+#endif
+ )
+
+--------------------------------------------------------------------------------
+-- Pretty-printing
+--------------------------------------------------------------------------------
+
+toText :: (Outputable a) => DynFlags -> a -> T.Text
+toText flags = T.pack . showSDoc flags . ppr
+
+instanceToText :: DynFlags -> ClsInst -> T.Text
+instanceToText flags ClsInst {..} =
+ T.append "instance " $ T.pack . showSDoc flags $ pprSigmaType (idType is_dfun)
+
+instanceDeclToText :: DynFlags -> InstDecl Name -> T.Text
+instanceDeclToText flags decl =
+ case decl of
+ ClsInstD ClsInstDecl {..} -> T.append "instance " (toText flags cid_poly_ty)
+ DataFamInstD di ->
+ let args =
+ T.intercalate " " . map (toText flags) . hsib_body $ dfid_pats di
+ in T.concat
+ ["data instance ", toText flags (unLoc $ dfid_tycon di), " ", args]
+ TyFamInstD ti ->
+ let args =
+ T.intercalate " " .
+ map (toText flags) . hsib_body . tfe_pats . unLoc . tfid_eqn $
+ ti
+ in T.concat
+ ["type instance ", toText flags $ tyFamInstDeclName ti, " ", args]
+
+nameToText :: Name -> T.Text
+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 _ = False
+ in case tyClDecl of
+ FamDecl _
+ | isDataFamilyDecl tyClDecl -> "data family "
+ | otherwise -> "type family "
+ SynDecl {} -> "type "
+ DataDecl {}
+ | isNewTy tyClDecl -> "newtype "
+ | otherwise -> "data "
+ ClassDecl {} -> "class "
+
+demangleOccName :: Name -> T.Text
+demangleOccName name
+ | isDerivedOccName (nameOccName name) =
+ let removePrefix :: T.Text -> T.Text
+ removePrefix 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
+ | T.isPrefixOf "$b" occName = T.drop 2 occName
+ | T.isPrefixOf "$dm" occName = T.drop 3 occName
+ | T.isPrefixOf "$c" occName = T.drop 2 occName
+ | T.isPrefixOf "$d" occName = T.drop 2 occName
+ | T.isPrefixOf "$i" occName = T.drop 2 occName
+ | T.isPrefixOf "$s" occName = T.drop 2 occName
+ | T.isPrefixOf "$f" occName = T.drop 2 occName
+ | T.isPrefixOf "$r" occName = T.drop 2 occName
+ | T.isPrefixOf "C:" occName = T.drop 2 occName
+ | T.isPrefixOf "N:" occName = T.drop 2 occName
+ | 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
+
+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
+
+occNameNameSpace :: OccName -> HCE.NameSpace
+occNameNameSpace n
+ | isVarNameSpace (occNameSpace n) = HCE.VarName
+ | isDataConNameSpace (occNameSpace n) = HCE.DataName
+ | isTvNameSpace (occNameSpace n) = HCE.TvName
+ | 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 _ 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 _ = Nothing
+
+--------------------------------------------------------------------------------
+-- Syntax transformation
+--------------------------------------------------------------------------------
+
+hsGroupVals :: HsGroup Name -> [GenLocated SrcSpan (HsBindLR Name Name)]
+hsGroupVals hsGroup =
+ filter (isGoodSrcSpan . getLoc) $
+ case hs_valds hsGroup of
+ ValBindsOut binds _ -> concatMap (bagToList . snd) binds
+ _ -> []
+
+hsPatSynDetails :: HsPatSynDetails a -> [a]
+hsPatSynDetails patDetails =
+ case patDetails of
+ InfixPatSyn name1 name2 -> [name1, name2]
+ PrefixPatSyn name -> name
+ RecordPatSyn fields ->
+ concatMap
+ (\field -> [recordPatSynSelectorId field, recordPatSynPatVar field])
+ fields
+
+#if 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
+
+ieLocNames :: IE Name -> [Located Name]
+ieLocNames (IEVar n) = [unwrapName n]
+ieLocNames (IEThingAbs n) = [unwrapName n]
+ieLocNames (IEThingAll n) = [unwrapName n]
+ieLocNames (IEThingWith n _ ns labels) =
+ unwrapName n : (map unwrapName ns ++ map (fmap flSelector) labels)
+ieLocNames (IEModuleContents (L _ _)) = []
+ieLocNames (IEGroup _ _) = []
+ieLocNames (IEDoc _) = []
+ieLocNames (IEDocNamed _) = []
+
+--------------------------------------------------------------------------------
+-- Lookups
+--------------------------------------------------------------------------------
+
+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
+ case mbTyThing of
+ Just tyThing -> tyThingToId tyThing
+ _ -> Nothing
+
+lookupNameModuleAndPackage ::
+ DynFlags
+ -> HCE.PackageId
+ -> Name
+ -> Either T.Text (HCE.HaskellModuleName, HCE.PackageId)
+lookupNameModuleAndPackage flags currentPackageId name =
+ case nameModule_maybe name of
+ Just Module {..} ->
+ case lookupPackage flags moduleUnitId of
+ Just packageConfig ->
+ let packageId =
+ if (T.pack . packageNameString $ packageConfig) ==
+ HCE.name (currentPackageId :: HCE.PackageId)
+ then currentPackageId
+ else HCE.PackageId
+ (T.pack $ packageNameString packageConfig)
+ (PackageConfig.packageVersion packageConfig)
+ 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"]
+
+--------------------------------------------------------------------------------
+-- Location info
+--------------------------------------------------------------------------------
+
+isHsBoot :: HCE.HaskellModulePath -> Bool
+isHsBoot = T.isSuffixOf "-boot" . HCE.getHaskellModulePath
+
+moduleLocationInfo ::
+ DynFlags
+ -> HM.HashMap HCE.HaskellModuleName (HM.HashMap HCE.ComponentId HCE.HaskellModulePath)
+ -> HCE.PackageId
+ -> HCE.ComponentId
+ -> ModuleName
+ -> HCE.LocationInfo
+moduleLocationInfo flags 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
+ Just modulePathMap
+ | Just modulePath <- HM.lookup compId modulePathMap ->
+ HCE.ExactLocation
+ currentPackageId
+ modulePath
+ (HCE.HaskellModuleName moduleNameText)
+ 1
+ 1
+ 1
+ 1
+ _ ->
+ case lookupModuleWithSuggestions flags moduleName Nothing of
+ LookupFound Module {moduleUnitId = unitId} _ ->
+ case lookupPackage flags unitId of
+ Just packInfo ->
+ let packageId =
+ HCE.PackageId
+ (T.pack $ packageNameString packInfo)
+ (PackageConfig.packageVersion packInfo)
+ 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)
+
+nameLocationInfo ::
+ DynFlags
+ -> HCE.PackageId
+ -> HCE.ComponentId
+ -> HCE.SourceCodeTransformation
+ -> HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath
+ -> HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap
+ -> Maybe T.Text -- ^ Instance head (when name is a dictionary function)
+ -> Maybe SrcSpan -- ^ Only for wired-in names
+ -> Name
+ -> HCE.LocationInfo
+nameLocationInfo flags 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
+ flags
+ 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 flags 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 name mbSrcSpan =
+ case nameSrcSpan name of
+ RealSrcSpan span -> Just span
+ _
+ | isWiredInName name ->
+ case mbSrcSpan of
+ Just span ->
+ case span of
+ RealSrcSpan s -> Just s
+ _ -> Nothing
+ _ -> Nothing
+ _ -> Nothing
+nameLocationInfo flags currentPackageId compId _transformation _fileMap _defSiteMap mbInstanceHead _mbSrcSpan name =
+ mkApproximateLocation flags currentPackageId compId mbInstanceHead name
+
+mkApproximateLocation ::
+ DynFlags
+ -> HCE.PackageId
+ -> HCE.ComponentId
+ -> Maybe T.Text
+ -> Name
+ -> HCE.LocationInfo
+mkApproximateLocation flags currentPackageId compId mbInstanceHead name =
+ let haddockAnchor =
+ Just . T.pack . makeAnchorId . T.unpack . nameToText $ name
+ in case lookupNameModuleAndPackage flags 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
+ -> 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
+ }
+
+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
+ ]
+ defSiteLocation = HCE.location :: HCE.DefinitionSite -> HCE.LocationInfo
+ 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
+ HCE.Inst -> lookupLocation HCE.instances (\t -> t)
+ HCE.Mod -> HCE.UnknownLocation errorMessage
+
+nameDocumentation ::
+ HCE.SourceCodeTransformation
+ -> HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath
+ -> HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap
+ -> HCE.DefinitionSiteMap
+ -> Name
+ -> 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
+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)
+ -> 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
+ HCE.DataName -> lookupDoc HCE.values
+ _ -> 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
+ -> SrcSpan
+ -> Maybe (HCE.HaskellFilePath, (Int, Int), (Int, Int))
+srcSpanToLineAndColNumbers transformation (RealSrcSpan s) =
+ let filePath =
+ HCE.HaskellFilePath . T.pack . normalise . unpackFS . srcSpanFile $ s
+ eitherStart =
+ HCE.fromOriginalLineNumber transformation (filePath, srcSpanStartLine s)
+ eitherEnd =
+ HCE.fromOriginalLineNumber transformation (filePath, srcSpanEndLine s)
+ in case (,) eitherStart eitherEnd of
+ (Right startLine, Right endLine) ->
+ Just
+ ( filePath
+ , (startLine, srcSpanStartCol s)
+ , (endLine, srcSpanEndCol s))
+ _ -> Nothing
+srcSpanToLineAndColNumbers _ _ = Nothing
+
+--------------------------------------------------------------------------------
+-- Type-related functions
+--------------------------------------------------------------------------------
+
+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
+
+tidyIdentifierType :: TidyEnv -> Id -> (TidyEnv, Id)
+tidyIdentifierType tidyEnv identifier =
+ let (tidyEnv', typ') = tidyOpenType tidyEnv (varType identifier)
+ in (tidyEnv', setVarType identifier typ')
+
+patSynId :: PatSyn -> Id
+patSynId patSyn =
+ let (univTvs, reqTheta, exTvs, provTheta, argTys, resTy) = patSynSig patSyn
+ reqTheta'
+ | null reqTheta && not (null provTheta && null exTvs) = [unitTy]
+ | otherwise = reqTheta
+ -- required => provided => arg_1 -> ... -> arg_n -> res
+ patSynTy =
+ mkInvForAllTys univTvs $
+ mkFunTys reqTheta' $
+ mkInvForAllTys exTvs $ mkFunTys provTheta $ mkFunTys argTys resTy
+ in flip setVarType patSynTy . fst . patSynMatcher $ patSyn
+
+applyWrapper :: HsWrapper -> Type -> Type
+applyWrapper wp ty
+ | Just ty' <- coreView ty = applyWrapper wp ty'
+applyWrapper WpHole t = t
+applyWrapper (WpCompose w1 w2) t = applyWrapper w1 . applyWrapper w2 $ t
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+applyWrapper (WpFun w1 w2 t1 _doc) t = mkFunTy t1 (applyWrapper w2 $ piResultTy t (applyWrapper w1 t1))
+#else
+applyWrapper (WpFun w1 w2 t1) t = mkFunTy t1 (applyWrapper w2 $ piResultTy t (applyWrapper w1 t1))
+#endif
+applyWrapper (WpCast coercion) _t = pSnd $ tcCoercionKind coercion
+applyWrapper (WpEvLam v) t = mkFunTy (evVarPred v) t
+applyWrapper (WpEvApp _ev) t = case splitFunTy_maybe t of
+ Just (_arg,res) -> res
+ Nothing -> t
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+applyWrapper (WpTyLam v) t = mkForAllTy v Required t
+#else
+applyWrapper (WpTyLam v) t = mkForAllTy (mkNamedBinder Invisible v) t
+#endif
+applyWrapper (WpTyApp t') t = piResultTy t t'
+applyWrapper (WpLet _) t = t
+
+wrapperTypes :: HsWrapper -> [Type]
+wrapperTypes WpHole = []
+wrapperTypes (WpCompose w1 w2) = wrapperTypes w2 ++ wrapperTypes w1
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+wrapperTypes (WpFun w1 w2 _ _) = wrapperTypes w2 ++ wrapperTypes w1
+#else
+wrapperTypes (WpFun w1 w2 _) = wrapperTypes w2 ++ wrapperTypes w1
+#endif
+wrapperTypes (WpCast _) = []
+wrapperTypes (WpEvLam _) = []
+wrapperTypes (WpEvApp _) = []
+wrapperTypes (WpTyLam _) = []
+wrapperTypes (WpTyApp t) = [t]
+wrapperTypes (WpLet _) = []
+
+mkType :: DynFlags -> Type -> HCE.Type
+mkType flags typ =
+ let typeExpanded = expandTypeSynonyms typ
+ typeComponents = toTypeComponents flags typ
+ typeComponentsExpanded = toTypeComponents flags typeExpanded
+ in HCE.Type
+ typeComponents
+ (if typeComponents /= typeComponentsExpanded
+ 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
+ -- Signature with OccNames and uniques
+ 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
+ -- 2. Character ',' cannot appear in an 'OccName'
+ -- 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)
+ 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)
+
+-- | 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
+
+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
+
+--------------------------------------------------------------------------------
+-- Documentation processing
+-- Some functions are copied from haddock-api package
+--------------------------------------------------------------------------------
+
+collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])]
+collectDocs = go Nothing []
+ where
+ go Nothing _ [] = []
+ go (Just prev) docs [] = finished prev docs []
+ go prev docs (L _ (DocD (DocCommentNext str)):ds)
+ | Nothing <- prev = go Nothing (str : docs) ds
+ | Just decl <- prev = finished decl docs (go Nothing [str] ds)
+ go prev docs (L _ (DocD (DocCommentPrev str)):ds) = go prev (str : docs) ds
+ go Nothing docs (d:ds) = go (Just d) docs ds
+ go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
+ finished decl docs rest = (decl, reverse docs) : rest
+
+ungroup :: HsGroup Name -> [LHsDecl Name]
+ungroup group_ =
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++
+#else
+ mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++
+#endif
+ mkDecls hs_derivds DerivD group_ ++
+ mkDecls hs_defds DefD group_ ++
+ mkDecls hs_fords ForD group_ ++
+ mkDecls hs_docs DocD group_ ++
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ mkDecls hsGroupInstDecls InstD group_ ++
+#else
+ mkDecls hs_instds InstD group_ ++
+#endif
+ mkDecls (typesigs . hs_valds) SigD group_ ++
+ mkDecls (valbinds . hs_valds) ValD group_
+ where
+ typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs
+ typesigs _ = []
+ valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds
+ valbinds _ = []
+
+mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
+mkDecls field con struct = [L loc (con decl) | L loc decl <- field struct]
+
+sortByLoc :: [Located a] -> [Located a]
+sortByLoc = L.sortBy (comparing getLoc)
+
+classDeclDocs :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])]
+classDeclDocs class_ = collectDocs . sortByLoc $ decls
+ where
+ decls = docs ++ defs ++ sigs ++ ats
+ docs = mkDecls tcdDocs DocD class_
+ defs = mkDecls (bagToList . tcdMeths) ValD class_
+ sigs = mkDecls tcdSigs SigD class_
+ ats = mkDecls tcdATs (TyClD . FamDecl) class_
+
+conDeclDocs :: ConDecl Name -> [(Name, [HsDocString], SrcSpan)]
+conDeclDocs conDecl =
+ map (\(L span n) -> (n, maybe [] ((: []) . unLoc) $ con_doc conDecl, span)) .
+ getConNames $
+ conDecl
+
+selectorDocs :: ConDecl name -> [(PostRn name name, [HsDocString], SrcSpan)]
+selectorDocs con =
+ case getConDetails con of
+ RecCon (L _ flds) ->
+ concatMap
+ (\(L _ (ConDeclField fieldOccs _ mbDoc)) ->
+ map
+ (\(L span f) ->
+ (selectorFieldOcc f, maybe [] ((: []) . unLoc) mbDoc, span))
+ fieldOccs)
+ flds
+ _ -> []
+
+subordinateNamesWithDocs ::
+ [GenLocated SrcSpan (HsDecl Name)] -> [(Name, [HsDocString], SrcSpan)]
+subordinateNamesWithDocs =
+ concatMap
+ (\(L span tyClDecl) ->
+ case tyClDecl of
+ TyClD classDecl@ClassDecl {..} ->
+ concatMap
+ (\(L _ decl, docs) -> map (, docs, span) $ getMainDeclBinder decl) $
+ classDeclDocs classDecl
+ TyClD DataDecl {..} ->
+ concatMap (\(L _ con) -> conDeclDocs con ++ selectorDocs con) $
+ dd_cons tcdDataDefn
+ InstD (DataFamInstD DataFamInstDecl {..}) ->
+ concatMap (conDeclDocs . unLoc) . dd_cons $ dfid_defn
+ _ -> [])
+
+isUserLSig :: LSig name -> Bool
+isUserLSig (L _ TypeSig {}) = True
+isUserLSig (L _ ClassOpSig {}) = True
+isUserLSig _ = False
+
+getMainDeclBinder :: HsDecl name -> [name]
+getMainDeclBinder (TyClD d) = [tcdName d]
+getMainDeclBinder (ValD d) =
+ case collectHsBindBinders d of
+ [] -> []
+ (name:_) -> [name]
+getMainDeclBinder (SigD d) = sigNameNoLoc d
+getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]
+getMainDeclBinder (ForD ForeignExport {}) = []
+getMainDeclBinder _ = []
+
+sigNameNoLoc :: Sig name -> [name]
+sigNameNoLoc (TypeSig ns _) = map unLoc ns
+sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+sigNameNoLoc (PatSynSig ns _) = map unLoc ns
+#else
+sigNameNoLoc (PatSynSig n _) = [unLoc n]
+#endif
+sigNameNoLoc (SpecSig n _ _) = [unLoc n]
+sigNameNoLoc (InlineSig n _) = [unLoc n]
+sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns
+sigNameNoLoc _ = []
+
+clsInstDeclSrcSpan :: ClsInstDecl name -> SrcSpan
+clsInstDeclSrcSpan ClsInstDecl {cid_poly_ty = ty} = getLoc (hsSigType ty)
+
+hsDocsToDocH :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Doc Name
+hsDocsToDocH flags rdrEnv =
+ rename flags rdrEnv .
+ overIdentifier (parseIdent flags) .
+ _doc . parseParas . concatMap (unpackFS . (\(HsDocString s) -> s))
+
+parseIdent :: DynFlags -> String -> Maybe RdrName
+parseIdent dflags str0 =
+ let buffer = stringToStringBuffer str0
+ realSrcLc = mkRealSrcLoc (mkFastString "<unknown file>") 0 0
+ pstate = mkPState 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 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 gre_name (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 str -> DocModule str
+ DocHyperlink l -> DocHyperlink l
+ 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)
+
+-- | Wrap an identifier that's out of scope (i.e. wasn't found in
+-- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently
+-- we simply monospace the identifier in most cases except when the
+-- identifier is qualified: if the identifier is qualified then we can
+-- still try to guess and generate anchors accross modules but the
+-- users shouldn't rely on this doing the right thing. See tickets
+-- #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 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
diff --git a/src/HaskellCodeExplorer/ModuleInfo.hs b/src/HaskellCodeExplorer/ModuleInfo.hs
new file mode 100644
index 0000000..cc81a36
--- /dev/null
+++ b/src/HaskellCodeExplorer/ModuleInfo.hs
@@ -0,0 +1,811 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StrictData #-}
+
+module HaskellCodeExplorer.ModuleInfo
+ ( createModuleInfo
+ , 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 Data.Ord(comparing)
+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 DynFlags(DynFlags)
+import GHC
+ ( GenLocated(..)
+ , 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 Type(expandTypeSynonyms)
+import 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 HsBinds(HsBindLR)
+import HsDecls
+ ( ForeignDecl(..)
+ , HsDecl(..)
+ , HsGroup(..)
+ , InstDecl
+ , InstDecl(..)
+ , TyClDecl
+ , group_tyclds
+ , tyClDeclLName
+ , tcdName
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ , hsGroupInstDecls
+#endif
+ )
+import HsDoc(HsDocString)
+import HsImpExp (IE(..), ImportDecl(..))
+import HsUtils(collectHsBindBinders)
+import HscTypes
+ ( ExternalPackageState
+ , HomePackageTable
+ , TypeEnv
+ , eps_PTE
+ , eps_inst_env
+ , hm_details
+ , md_types
+ , mkTypeEnv
+ , typeEnvElts
+ )
+import InstEnv (InstEnvs(..), is_dfun)
+import Module(Module(..))
+import Name (Name, OccName, getSrcSpan, nameOccName, nameSrcSpan, nameUnique)
+import Prelude hiding(id,span)
+import RdrName(GlobalRdrEnv)
+import SrcLoc (isOneLineSpan)
+import TcRnTypes (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
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+import UniqDFM (eltsUDFM)
+#else
+import UniqFM (eltsUFM)
+#endif
+import Unique (getKey)
+import Var (varName, varType,Id)
+import VarEnv (emptyTidyEnv)
+
+type ModuleDependencies
+ = ( 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
+ , TypecheckedModule
+ , HomePackageTable
+ , ExternalPackageState
+ , ModSummary)
+
+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, 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
+ --------------------------------------------------------------------------------
+ -- Type environment
+ --------------------------------------------------------------------------------
+ (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
+ externalPackagesTyThings = typeEnvElts $ eps_PTE externalPackageState
+ typeEnv =
+ mkTypeEnv
+ (currentModuleTyThings ++
+ homePackageTyThings ++ externalPackagesTyThings)
+ --------------------------------------------------------------------------------
+ -- Exported entities
+ --------------------------------------------------------------------------------
+ dataFamTyCons =
+ mapMaybe
+ (\case
+ ATyCon tc
+ | isFamInstTyCon tc -> Just $ tyConName tc
+ _ -> Nothing)
+ currentModuleTyThings
+ (defSites, allNames) =
+ createDefinitionSiteMap
+ flags
+ currentPackageId
+ compId
+ defSiteMap
+ fileMap
+ globalRdrEnv
+ transformation
+ modInfo
+ dataFamTyCons
+ hsGroup
+ --------------------------------------------------------------------------------
+ -- Instance environment
+ --------------------------------------------------------------------------------
+ homeInstEnv = tcg_inst_env tcGblEnv
+ visOrphanModules = tcVisibleOrphanMods tcGblEnv
+ packageInstEnv = eps_inst_env externalPackageState
+ instEnv = InstEnvs packageInstEnv homeInstEnv visOrphanModules
+ --------------------------------------------------------------------------------
+ declarations =
+ createDeclarations flags hsGroup typeEnv exportedNamesSet transformation
+ environment =
+ Environment
+ { envDynFlags = flags
+ , 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
+ 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
+ }
+ , if not $ isHsBoot modulePath
+ then (HM.union
+ (HM.fromList .
+ (( HCE.HaskellFilePath $ HCE.getHaskellModulePath modulePath
+ , modulePath) :) .
+ map (\includedFile -> (includedFile, 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
+ , sourceInfoTypeErrors :: [TypeError]
+ } 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
+
+prepareSourceCode ::
+ HCE.SourceCodePreprocessing
+ -> T.Text
+ -> ModSummary
+ -> HCE.HaskellModulePath
+ -> (HCE.SourceCodeTransformation, T.Text)
+prepareSourceCode sourceCodePreprocessing originalSourceCode modSum modulePath =
+ let sourceCodeAfterPreprocessing =
+ case TE.decodeUtf8'
+ (fromMaybe (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
+ -> HCE.PackageId
+ -> HCE.ComponentId
+ -> HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap
+ -> HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath
+ -> GlobalRdrEnv
+ -> HCE.SourceCodeTransformation
+ -> ModuleInfo
+ -> [Name]
+ -> HsGroup Name
+ -> (HCE.DefinitionSiteMap, [Name])
+createDefinitionSiteMap flags currentPackageId compId defSiteMap fileMap globalRdrEnv transformation modInfo dataFamTyCons hsGroup =
+ let allDecls :: [GenLocated SrcSpan (HsDecl Name)]
+ allDecls = L.sortBy (comparing getLoc) . ungroup $ hsGroup
+ (instanceDeclsWithDocs, valueAndTypeDeclsWithDocs) =
+ L.partition
+ (\(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
+ InstD (ClsInstD inst) -> Just (clsInstDeclSrcSpan inst, docs)
+ _ -> Nothing) $
+ instanceDeclsWithDocs
+ nameLocation :: Maybe SrcSpan -> Name -> HCE.LocationInfo
+ nameLocation =
+ nameLocationInfo
+ flags
+ currentPackageId
+ compId
+ transformation
+ fileMap
+ defSiteMap
+ Nothing
+ docHToHtml :: DocH (ModuleName, OccName) Name -> HCE.HTML
+ docHToHtml =
+ docWithNamesToHtml
+ flags
+ currentPackageId
+ compId
+ transformation
+ fileMap
+ defSiteMap
+ instancesWithDocumentation =
+ HM.fromList .
+ map
+ (\clsInst ->
+ ( instanceToText flags clsInst
+ , let location =
+ nameLocation Nothing (Var.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
+ (\(L span decl, docs) -> map (, docs, span) $ 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)]
+ -> 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)
+
+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)
+
+nameToHtml ::
+ DynFlags
+ -> HCE.PackageId
+ -> HCE.ComponentId
+ -> HCE.SourceCodeTransformation
+ -> HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath
+ -> HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap
+ -> Name
+ -> H.Html
+nameToHtml flags packageId compId transformation files defSiteMap name =
+ let location =
+ H.textValue . toStrict . encodeToLazyText . Aeson.toJSON $
+ nameLocationInfo
+ flags
+ 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
+ -> HCE.PackageId
+ -> HCE.ComponentId
+ -> HCE.SourceCodeTransformation
+ -> HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath
+ -> HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap
+ -> DocH (ModuleName, OccName) Name
+ -> HCE.HTML
+docWithNamesToHtml flags packageId compId transformation fileMap defSiteMap =
+ HCE.docToHtml
+ (occNameToHtml flags packageId compId)
+ (nameToHtml flags packageId compId transformation fileMap defSiteMap)
+
+createDeclarations ::
+ DynFlags
+ -> HsGroup Name
+ -> TypeEnv
+ -> S.Set Name
+ -> HCE.SourceCodeTransformation
+ -> [HCE.Declaration]
+createDeclarations flags hsGroup typeEnv exportedSet transformation =
+ let lineNumber :: SrcSpan -> Int
+ lineNumber srcSpan =
+ case srcSpanToLineAndColNumbers transformation srcSpan of
+ 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
+ -- | Top-level functions
+ --------------------------------------------------------------------------------
+ valToDeclarations ::
+ GenLocated SrcSpan (HsBindLR Name Name) -> [HCE.Declaration]
+ valToDeclarations (L loc bind) =
+ map
+ (\name ->
+ HCE.Declaration
+ HCE.ValD
+ (toText flags name)
+ (nameType name)
+ (S.member name exportedSet)
+ (lineNumber loc)) $
+ collectHsBindBinders bind
+ vals = concatMap valToDeclarations $ hsGroupVals hsGroup
+ -- | Data, newtype, type, type family, data family or class declaration
+ --------------------------------------------------------------------------------
+ tyClToDeclaration :: GenLocated SrcSpan (TyClDecl Name) -> HCE.Declaration
+ tyClToDeclaration (L loc tyClDecl) =
+ HCE.Declaration
+ HCE.TyClD
+ (T.append (tyClDeclPrefix tyClDecl) (toText flags $ tcdName tyClDecl))
+ (nameType $ tcdName tyClDecl)
+ (S.member (unLoc $ tyClDeclLName tyClDecl) exportedSet)
+ (lineNumber loc)
+ tyclds =
+ map tyClToDeclaration .
+ filter (isGoodSrcSpan . getLoc) . concatMap group_tyclds . hs_tyclds $
+ hsGroup
+ -- | Instances
+ --------------------------------------------------------------------------------
+ instToDeclaration :: GenLocated SrcSpan (InstDecl Name) -> HCE.Declaration
+ instToDeclaration (L loc inst) =
+ HCE.Declaration
+ HCE.InstD
+ (instanceDeclToText flags inst)
+ Nothing
+ True
+ (lineNumber loc)
+ insts =
+#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+ map instToDeclaration . filter (isGoodSrcSpan . getLoc) . hsGroupInstDecls $
+#else
+ map instToDeclaration . filter (isGoodSrcSpan . getLoc) . hs_instds $
+#endif
+ hsGroup
+ -- | Foreign functions
+ --------------------------------------------------------------------------------
+ foreignFunToDeclaration ::
+ GenLocated SrcSpan (ForeignDecl Name) -> HCE.Declaration
+ foreignFunToDeclaration (L loc fd) =
+ let name = unLoc $ fd_name fd
+ in HCE.Declaration
+ HCE.ForD
+ (toText flags name)
+ (nameType name)
+ True
+ (lineNumber loc)
+ fords = map foreignFunToDeclaration $ hs_fords hsGroup
+ --------------------------------------------------------------------------------
+ in L.sortBy (comparing 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
+
+ -- 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)
+ flags = envDynFlags environment
+ packageId = envPackageId environment
+ compId = envComponentId environment
+ importedModules =
+ map
+ ((\(L span modName) ->
+ ( modName
+ , span
+ , moduleLocationInfo
+ flags
+ (envModuleNameMap environment)
+ packageId
+ compId
+ modName)) .
+ ideclName . unLoc) .
+ filter (not . ideclImplicit . unLoc) $
+ importDecls
+ exportedModules =
+ case mbExported of
+ Just lieNames ->
+ mapMaybe
+ (\(L span ie) ->
+ case ie of
+ IEModuleContents (L _ modName) ->
+ Just
+ ( modName
+ , span
+ , moduleLocationInfo
+ flags
+ (envModuleNameMap environment)
+ packageId
+ compId
+ modName)
+ _ -> Nothing)
+ lieNames
+ Nothing -> []
+ addImportedAndExportedModulesToIdOccMap ::
+ HCE.IdentifierOccurrenceMap -> HCE.IdentifierOccurrenceMap
+ addImportedAndExportedModulesToIdOccMap =
+ IM.map (L.sortBy $ comparing 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
+ -> 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)
+ , Just (_, (lineNumber, startCol), (_, endCol)) <-
+ srcSpanToLineAndColNumbers (envTransformation environment) .
+ getLoc . locatedName $
+ nameOcc =
+ case nameOcc of
+ TyLitOccurrence {kind = kind} ->
+ addTypeToMaps
+ 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
+ (Var.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
+ ->
+ case unLoc $ locatedName nameOcc of
+ Just name ->
+ addTypeToMaps
+ environment
+ idMaps
+ Nothing
+ (Just name)
+ (description nameOcc)
+ lineNumber
+ startCol
+ endCol
+ Nothing -> idMaps
+addIdentifierToMaps _ _ idMaps _ = idMaps
+
+addTypeToMaps ::
+ Environment
+ -> (HCE.IdentifierInfoMap, HCE.IdentifierOccurrenceMap)
+ -> Maybe Type
+ -> Maybe Name
+ -> T.Text
+ -> Int
+ -> Int
+ -> Int
+ -> (HCE.IdentifierInfoMap, HCE.IdentifierOccurrenceMap)
+addTypeToMaps 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)
+ 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 = HCE.TypeId
+ }
+ idOccMap' =
+ IM.insertWith
+ removeOverlappingInterval
+ lineNumber
+ [((colStart, colEnd), idOcc)]
+ idOccMap
+ in (idInfoMap', idOccMap')
+
+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
+ 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
+
+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 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
+
+addModules ::
+ HCE.SourceCodeTransformation
+ -> [(ModuleName, SrcSpan, HCE.LocationInfo)]
+ -> HCE.IdentifierOccurrenceMap
+ -> HCE.IdentifierOccurrenceMap
+addModules transformation modules idMap =
+ 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
+ update idOccMap _ = idOccMap
+ in L.foldl' update idMap modules
diff --git a/src/HaskellCodeExplorer/PackageInfo.hs b/src/HaskellCodeExplorer/PackageInfo.hs
new file mode 100644
index 0000000..f384a74
--- /dev/null
+++ b/src/HaskellCodeExplorer/PackageInfo.hs
@@ -0,0 +1,595 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HaskellCodeExplorer.PackageInfo
+ ( createPackageInfo
+ ) where
+
+import Control.DeepSeq(deepseq)
+import Control.Exception
+ ( IOException
+ , SomeAsyncException
+ , SomeException
+ , fromException
+ , throw
+ , try
+ )
+import Control.Monad (foldM, join, unless)
+import Control.Monad.Extra (findM)
+import Control.Monad.Logger
+ ( LoggingT(..)
+ , MonadLogger(..)
+ , MonadLoggerIO(..)
+ , logDebugN
+ , logErrorN
+ , logInfoN
+ )
+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)
+import qualified Data.Set as S
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Digraph (flattenSCCs)
+import Distribution.Helper
+ ( ChComponentName(..)
+ , ChEntrypoint(..)
+ , ChModuleName(..)
+ , components
+ , entrypoints
+ , ghcOptions
+ , mkQueryEnv
+ , packageId
+ , runQuery
+ , sourceDirs
+ )
+import DynFlags
+ ( DynFlags(..)
+ , GeneralFlag(..)
+ , GhcMode(..)
+ , WarnReason(..)
+ , gopt_set
+ , parseDynamicFlagsCmdLine
+ )
+import Exception (ExceptionMonad(..), ghandle)
+import GHC
+ ( GhcLink(..)
+ , HscTarget(..)
+ , LoadHowMuch(..)
+ , ModLocation(..)
+ , ModSummary(..)
+ , Severity
+ , SrcSpan
+ , getModuleGraph
+ , getSession
+ , getSessionDynFlags
+ , guessTarget
+ , load
+ , noLoc
+ , parseModule
+ , runGhcT
+ , setSessionDynFlags
+ , setTargets
+ , topSortModuleGraph
+ , typecheckModule
+ , moduleNameString
+ , moduleName
+ )
+import GHC.Paths (libdir)
+import GhcMonad (GhcT(..), liftIO)
+import HaskellCodeExplorer.GhcUtils (isHsBoot,toText)
+import HaskellCodeExplorer.ModuleInfo (ModuleDependencies, createModuleInfo)
+import qualified HaskellCodeExplorer.Types as HCE
+import HscTypes (hsc_EPS, hsc_HPT)
+import Outputable (PprStyle, SDoc, neverQualify, showSDocForUser)
+import Packages (initPackages)
+import Prelude hiding (id)
+import System.Directory
+ ( doesFileExist
+ , doesFileExist
+ , findExecutable
+ , setCurrentDirectory
+ , getCurrentDirectory
+ , makeAbsolute
+ )
+import qualified System.Directory.Tree as DT
+import System.FilePath
+ ( (</>)
+ , addTrailingPathSeparator
+ , joinPath
+ , normalise
+ , replaceExtension
+ , splitPath
+ , takeExtension
+ , takeBaseName
+ , splitDirectories
+ )
+import System.Process (readProcess)
+
+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
+ Just path -> return $ packageDirectoryAbsPath </> path
+ Nothing -> findDistDirectory packageDirectoryAbsPath
+ let cabalHelperQueryEnv = mkQueryEnv packageDirectoryAbsPath distDir
+ ((packageName, packageVersion), compInfo) <-
+ liftIO $
+ runQuery
+ cabalHelperQueryEnv
+ ((,) <$> packageId <*>
+ (zip3 <$> components ((,) <$> ghcOptions) <*>
+ components ((,) <$> entrypoints) <*>
+ components ((,) <$> sourceDirs)))
+ let currentPackageId = HCE.PackageId (T.pack packageName) packageVersion
+ 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
+ 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 (ChSubLibName name) =
+ HCE.SubLib $ T.pack name
+ 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 (ChSubLibName name) =
+ HCE.ComponentId . T.append "sublib-" . T.pack $ name
+ 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"
+
+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
+
+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
+
+addReferencesFromModule ::
+ HM.HashMap HCE.ExternalId (S.Set HCE.IdentifierSrcSpan)
+ -> HCE.ModuleInfo
+ -> HM.HashMap HCE.ExternalId (S.Set HCE.IdentifierSrcSpan)
+addReferencesFromModule references modInfo@HCE.ModuleInfo {..} =
+ eachIdentifierOccurrence
+ references
+ modInfo
+ (\occMap lineNumber startCol endCol occ ->
+ let mbIdExternalId =
+ join $
+ 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)
+
+findDistDirectory :: FilePath -> LoggingT IO FilePath
+findDistDirectory packagePath = do
+ hasStackYaml <- liftIO $ doesFileExist (packagePath </> "stack.yaml")
+ mbStackExecutable <- liftIO $ findExecutable "stack"
+ let defaultDistDir = packagePath </> "dist"
+ case (hasStackYaml, mbStackExecutable) of
+ (True, Just stack) -> do
+ let removeEndOfLine str
+ | null str = str
+ | otherwise = init str
+ eitherDistDir :: (Either IOException String) <-
+ liftIO .
+ try . fmap removeEndOfLine . readProcess stack ["path", "--dist-dir"] $
+ ""
+ case eitherDistDir of
+ Right distDir -> do
+ logDebugN $ T.append "Stack dist directory : " $ T.pack distDir
+ return distDir
+ Left exception -> do
+ logDebugN $
+ T.append
+ "Error while executing \"stack path --dist-dir\" : "
+ (T.pack . show $ exception)
+ return defaultDistDir
+ (False, _) -> do
+ logDebugN
+ "stack.yaml is not found in the package directory. Using default dist directory."
+ return defaultDistDir
+ (_, Nothing) -> do
+ logDebugN "stack executable is not found. Using default dist directory."
+ return defaultDistDir
+
+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
+
+instance ExceptionMonad (LoggingT IO) where
+ gcatch act h =
+ LoggingT $ \logFn ->
+ runLoggingT act logFn `gcatch` \e -> runLoggingT (h e) logFn
+ gmask f =
+ LoggingT $ \logFn ->
+ gmask $ \io_restore ->
+ let g_restore (LoggingT m) = LoggingT $ \lf -> io_restore (m lf)
+ in runLoggingT (f g_restore) logFn
+
+instance MonadLoggerIO (GhcT (LoggingT IO)) where
+ askLoggerIO = GhcT $ const askLoggerIO
+
+instance MonadLogger (GhcT (LoggingT IO)) where
+ monadLoggerLog loc source level =
+ GhcT . const . monadLoggerLog loc source level
+
+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 =
+ ghandle
+ (\ex ->
+ case fromException ex of
+ Just (asyncEx :: SomeAsyncException) -> throw asyncEx
+ _ -> onError ex)
+
+indexBuildComponent ::
+ HCE.SourceCodePreprocessing -- ^ Before or after preprocessor
+ -> HCE.PackageId -- ^ Current package id
+ -> HCE.ComponentId -- ^ Current component id
+ -> ModuleDependencies -- ^ Already indexed modules
+ -> [FilePath] -- ^ Src dirs
+ -> [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
+ [ "Error while indexing component "
+ , HCE.getComponentId componentId
+ , " : "
+ , T.pack . show $ ex
+ ]
+ 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 options : " $ T.pack $ show options)
+ flags <- getSessionDynFlags
+ (flags', _, _) <- parseDynamicFlagsCmdLine flags (L.map noLoc options)
+ (flags'', _) <- liftIO $ initPackages flags'
+ logFn <- askLoggerIO
+ let logAction ::
+ DynFlags
+ -> WarnReason
+ -> Severity
+ -> SrcSpan
+ -> Outputable.PprStyle
+ -> SDoc
+ -> IO ()
+ logAction fs _reason _severity srcSpan _stype msg =
+ runLoggingT
+ (logDebugN
+ (T.append "GHC message : " $
+ T.pack $
+ showSDocForUser fs neverQualify msg ++
+ " , SrcSpan : " ++ show srcSpan))
+ logFn
+ mbTmpDir =
+ case hiDir flags'' of
+ Just buildDir ->
+ Just $ buildDir </> (takeBaseName buildDir ++ "-tmp")
+ Nothing -> Nothing
+ _ <-
+ setSessionDynFlags $
+ L.foldl'
+ gopt_set
+ (flags''
+ { hscTarget = HscAsm
+ , ghcLink = LinkInMemory
+ , ghcMode = CompManager
+ , log_action = logAction
+ , importPaths = importPaths flags'' ++ maybeToList mbTmpDir
+ })
+ [Opt_Haddock]
+ targets <- mapM (`guessTarget` Nothing) modules
+ setTargets targets
+ _ <- load LoadAllTargets
+ modGraph <- getModuleGraph
+ let topSortMods = flattenSCCs (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)))
+ (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)
+ 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')))
+ ([], (fileMap, defSiteMap, modNameMap))
+ modSumWithPath
+
+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
+ -- File is in the build directory
+ Just path
+ | takeExtension path == ".hs-boot" -> do
+ let possiblePaths = path : map (</> path) srcDirs
+ mbFoundPath <- findM doesFileExist possiblePaths
+ case mbFoundPath of
+ Just p -> toHaskellModulePath p
+ _ -> return Nothing
+ | takeExtension path == ".hs" -> do
+ 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
+ | otherwise -> return Nothing
+ Nothing -> toHaskellModulePath modulePath
+ Nothing -> return Nothing
+
+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
+ logDebugN (T.append "Indexing " $ HCE.getHaskellModulePath modulePath)
+ 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)
+ let (modInfo, (fileMap', exportMap', moduleNameMap'), typeErrors) =
+ createModuleInfo
+ deps
+ ( flags
+ , typecheckedModule
+ , hsc_HPT hscEnv
+ , externalPackageState
+ , modSum)
+ modulePath
+ currentPackageId
+ componentId
+ (originalSourceCode, sourceCodePreprocessing)
+ unless (null typeErrors) $
+ logInfoN $ T.append "Type errors : " $ T.pack $ show typeErrors
+ deepseq modInfo $ return (modInfo, (fileMap', exportMap', moduleNameMap'))
diff --git a/src/HaskellCodeExplorer/Preprocessor.hs b/src/HaskellCodeExplorer/Preprocessor.hs
new file mode 100644
index 0000000..6a90ff9
--- /dev/null
+++ b/src/HaskellCodeExplorer/Preprocessor.hs
@@ -0,0 +1,159 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module HaskellCodeExplorer.Preprocessor
+ ( createSourceCodeTransformation
+ ) where
+
+import Control.Applicative ((<|>))
+import qualified Data.Attoparsec.Text as AT
+import Data.Foldable (foldl')
+import qualified Data.HashMap.Strict as HM
+import qualified Data.List as L
+import qualified Data.Set as S
+import qualified Data.Text as T
+import HaskellCodeExplorer.Types
+ ( FileLocation(..)
+ , HaskellFilePath(..)
+ , HaskellModulePath(..)
+ , LinePragma(..)
+ , SourceCodeTransformation(..)
+ , haskellPreprocessorExtensions
+ )
+import System.FilePath (normalise,takeExtension,takeFileName)
+
+
+-- | Finds locations of line pragmas and creates an index
+createSourceCodeTransformation ::
+ HaskellModulePath -> T.Text -> T.Text -> (SourceCodeTransformation, T.Text)
+createSourceCodeTransformation currentModulePath originalSourceCode sourceCodeAfterPreprocessing =
+ let sourceCodeLines = T.splitOn "\n" sourceCodeAfterPreprocessing
+ numberedLines = zip [1 :: Int ..] sourceCodeLines
+ currentFilePath =
+ HaskellFilePath . getHaskellModulePath $ currentModulePath
+ addPragma :: [LinePragma] -> (Int, T.Text) -> [LinePragma]
+ addPragma acc (lineNumber, line) =
+ case AT.parseOnly linePragmaParser line of
+ Right (originalLineNumber, mbFileName) ->
+ LinePragma
+ (maybe
+ currentFilePath
+ (HaskellFilePath . T.pack . normalise . T.unpack)
+ mbFileName)
+ lineNumber
+ originalLineNumber :
+ acc
+ Left _ -> acc
+ totalLines = length numberedLines
+ pragmas = L.reverse . L.foldl' addPragma [] $ numberedLines
+ pragmaPath = filePath :: LinePragma -> HaskellFilePath
+ currentFileExtension =
+ takeExtension . T.unpack . getHaskellFilePath $ currentFilePath
+ standardHeaderFiles = ["stdc-predef.h", "cabal_macros.h", "ghcversion.h"]
+ hasIncludedFiles =
+ L.any
+ ((\path ->
+ let fileName = takeFileName . T.unpack . getHaskellFilePath $ path
+ in (path /= currentFilePath) &&
+ (path /= HaskellFilePath "<built-in>") &&
+ (path /= HaskellFilePath "<command-line>") &&
+ not ("ghc_" `L.isPrefixOf` fileName) &&
+ (fileName `notElem` standardHeaderFiles)) .
+ pragmaPath)
+ pragmas
+ in if hasIncludedFiles ||
+ currentFileExtension `elem` haskellPreprocessorExtensions
+ then ( SourceCodeTransformation
+ totalLines
+ currentModulePath
+ (S.fromList pragmas)
+ (indexLocations totalLines currentFilePath pragmas)
+ , sourceCodeAfterPreprocessing)
+ else ( SourceCodeTransformation
+ (length $ T.splitOn "\n" originalSourceCode)
+ currentModulePath
+ S.empty
+ HM.empty
+ , originalSourceCode)
+
+-- | Parses line pragma
+linePragmaParser :: AT.Parser (Int, Maybe T.Text)
+linePragmaParser = pragma1 <|> pragma2
+ where
+ pragma1 :: AT.Parser (Int, Maybe T.Text)
+ pragma1 = parser "#" "line"
+
+ pragma2 :: AT.Parser (Int, Maybe T.Text)
+ pragma2 = parser "{-#" "LINE"
+
+ parser :: T.Text -> T.Text -> AT.Parser (Int, Maybe T.Text)
+ parser start line = do
+ _ <- AT.string start
+ _ <- AT.takeWhile (== ' ')
+ _ <- AT.string line <|> return ""
+ _ <- AT.takeWhile (== ' ')
+ num <- AT.decimal
+ _ <- AT.takeWhile (== ' ')
+ mbName <- (Just <$> fileName) <|> return Nothing
+ return (num, mbName)
+
+ fileName :: AT.Parser T.Text
+ fileName = AT.string "\"" *> AT.takeTill (== '\"') <* AT.string "\""
+
+data Line = FirstLine | LastLine Int | Pragma LinePragma deriving (Show,Eq)
+
+-- | Creates a HashMap whose keys are filenames and values are locations in a
+-- preprocessed source code
+indexLocations ::
+ Int
+ -> HaskellFilePath
+ -> [LinePragma]
+ -> HM.HashMap HaskellFilePath (S.Set FileLocation)
+indexLocations totalLines preprocessedFilePath pragmas =
+ foldl' add HM.empty . (zip <*> tail) $
+ (FirstLine : map Pragma pragmas) ++ [LastLine totalLines]
+ where
+ add ::
+ HM.HashMap HaskellFilePath (S.Set FileLocation)
+ -> (Line, Line)
+ -> HM.HashMap HaskellFilePath (S.Set FileLocation)
+ -- Interval between the first line and the first pragma
+ add hMap (FirstLine, Pragma LinePragma {..})
+ | lineNumberPreprocessed > 1 =
+ HM.insertWith
+ S.union
+ preprocessedFilePath
+ (S.singleton (FileLocation 1 lineNumberPreprocessed 0))
+ hMap
+ | otherwise = hMap
+ -- Interval between two pragmas
+ add hMap (Pragma (LinePragma fileName lineNumberPreprocessed1 lineNumberOriginal1),
+ Pragma (LinePragma _ lineNumberPreprocessed2 _))
+ | lineNumberPreprocessed2 - lineNumberPreprocessed1 > 1 =
+ HM.insertWith
+ S.union
+ fileName
+ (S.singleton
+ (FileLocation
+ lineNumberOriginal1
+ (lineNumberOriginal1 +
+ (lineNumberPreprocessed2 - lineNumberPreprocessed1 - 2))
+ (lineNumberPreprocessed1 - lineNumberOriginal1 + 1)))
+ hMap
+ | otherwise = hMap
+ -- Interval between the last pragma and the last line
+ add hMap (Pragma (LinePragma fileName lineNumberPreprocessed lineNumberOriginal),
+ LastLine lastLineNumberPreprocessed)
+ | lastLineNumberPreprocessed - lineNumberPreprocessed > 1 =
+ HM.insertWith
+ S.union
+ fileName
+ (S.singleton
+ (FileLocation
+ lineNumberOriginal
+ (lineNumberOriginal + (lastLineNumberPreprocessed - lineNumberPreprocessed - 2))
+ (lineNumberPreprocessed - lineNumberOriginal + 1)))
+ hMap
+ | otherwise = hMap
+ add hMap _ = hMap
diff --git a/src/HaskellCodeExplorer/Types.hs b/src/HaskellCodeExplorer/Types.hs
new file mode 100644
index 0000000..9e3667d
--- /dev/null
+++ b/src/HaskellCodeExplorer/Types.hs
@@ -0,0 +1,880 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HaskellCodeExplorer.Types where
+
+import Control.DeepSeq (NFData)
+import qualified Data.Aeson as A
+import Data.Aeson.Types (Options, defaultOptions, omitNothingFields)
+import Data.Generics
+ ( Constr
+ , Data(..)
+ , DataType
+ , Fixity(..)
+ , constrIndex
+ , gcast2
+ , mkConstr
+ , mkDataType
+ )
+import qualified Data.HashMap.Strict as HM
+import Data.Hashable (Hashable)
+import qualified Data.IntMap.Strict as IM
+import qualified Data.IntervalMap.Strict as IVM
+import qualified Data.List as L
+import Data.Maybe (fromMaybe, isJust)
+import Data.Serialize (Get, Serialize(..))
+import qualified Data.Set as S
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import Data.Text.Lazy (toStrict)
+import qualified Data.Vector as V
+import Data.Version (Version(..),showVersion)
+import Documentation.Haddock.Types
+ ( DocH(..)
+ , Example(..)
+ , Header(..)
+ , Hyperlink(..)
+ , Picture(..)
+ )
+import GHC.Generics (Generic)
+import Prelude hiding (id)
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+import qualified Text.Blaze.Html5 as Html
+import qualified Text.Blaze.Html5.Attributes as Attr
+
+--------------------------------------------------------------------------------
+-- Package info
+--------------------------------------------------------------------------------
+
+data PackageInfo modInfo = PackageInfo
+ { id :: PackageId
+ , moduleMap :: HM.HashMap HaskellModulePath modInfo
+ , moduleNameMap :: HM.HashMap HaskellModuleName (HM.HashMap ComponentId HaskellModulePath)
+ , directoryTree :: DirTree
+ , externalIdInfoMap :: Trie Char ExternalIdentifierInfo
+ -- ^ All external identifiers defined in the package
+ , externalIdOccMap :: HM.HashMap ExternalId (S.Set IdentifierSrcSpan)
+ -- ^ All occurrences of each external identifier in the package
+ } deriving (Show, Eq, Generic, Data)
+
+data PackageId = PackageId
+ { name :: T.Text
+ , version :: Data.Version.Version
+ } deriving (Show, Eq, Ord, Generic, Data)
+
+packageIdToText :: PackageId -> T.Text
+packageIdToText (PackageId name version) =
+ T.concat [name, "-", T.pack $ showVersion version]
+
+packageName :: PackageInfo a -> T.Text
+packageName =
+ (name :: (PackageId -> T.Text)) . (id :: PackageInfo a -> PackageId)
+
+data IdentifierSrcSpan = IdentifierSrcSpan
+ { modulePath :: HaskellModulePath
+ , line :: Int
+ , startColumn :: Int
+ , endColumn :: Int
+ } deriving (Show, Eq, Ord, Generic, Data)
+
+data DirTree
+ = Dir { name :: FilePath
+ , contents :: [DirTree] }
+ | File { name :: FilePath
+ , path :: FilePath
+ , isHaskellModule :: Bool }
+ deriving (Show, Eq, Generic, Data)
+
+newtype ComponentId = ComponentId
+ { getComponentId :: T.Text
+ } deriving (Show, Eq, Ord, Generic, A.ToJSONKey, Data, Hashable)
+
+data ComponentType
+ = Setup
+ | Lib
+ | SubLib T.Text
+ | FLib T.Text
+ | Exe T.Text
+ | Test T.Text
+ | Bench T.Text
+ deriving (Show, Eq, Generic, Data)
+
+isLibrary :: ComponentType -> Bool
+isLibrary Lib = True
+isLibrary (SubLib _) = True
+isLibrary (FLib _) = True
+isLibrary _ = False
+
+packageInfoBinaryFileName :: FilePath
+packageInfoBinaryFileName = "packageInfo"
+
+packageInfoJsonFileName :: FilePath
+packageInfoJsonFileName = "packageInfo.json"
+
+defaultOutputDirectoryName :: FilePath
+defaultOutputDirectoryName = ".haskell-code-explorer"
+
+--------------------------------------------------------------------------------
+-- A simple Trie implementation
+--------------------------------------------------------------------------------
+
+data Trie k v = Trie
+ { values :: S.Set v
+ , children :: HM.HashMap k (Trie k v)
+ } deriving (Show, Eq, Generic, Data)
+
+emptyTrie :: Trie k v
+emptyTrie = Trie S.empty HM.empty
+
+insertToTrie ::
+ (Hashable k, Eq k, Ord v)
+ => (v -> S.Set v -> S.Set v)
+ -> [k]
+ -> v
+ -> Trie k v
+ -> Trie k v
+insertToTrie f [] v (Trie vals children) = Trie (f v vals) children
+insertToTrie f word@(first:rest) val (Trie vals children) =
+ case HM.lookup first children of
+ Just trie ->
+ Trie vals (HM.insert first (insertToTrie f rest val trie) children)
+ Nothing ->
+ insertToTrie f word val (Trie vals (HM.insert first emptyTrie children))
+
+match :: (Hashable k, Eq k, Ord v) => [k] -> Trie k v -> S.Set v
+match (first:rest) (Trie _ children) =
+ maybe S.empty (match rest) (HM.lookup first children)
+match [] (Trie val children) =
+ S.union val $
+ S.unions
+ [S.union v $ match [] trie | (_, trie@(Trie v _)) <- HM.toList children]
+
+--------------------------------------------------------------------------------
+-- Module info
+--------------------------------------------------------------------------------
+
+data ModuleInfo = ModuleInfo
+ { id :: HaskellModulePath
+ , name :: HaskellModuleName
+ , source :: V.Vector T.Text
+ -- ^ Source code of the module
+ , transformation :: SourceCodeTransformation
+ , exprInfoMap :: ExpressionInfoMap
+ -- ^ Type of each expression in the module
+ , idOccMap :: IdentifierOccurrenceMap
+ -- ^ All occurrences of each identifier in the module
+ , idInfoMap :: IdentifierInfoMap
+ -- ^ Information about each identifier in the module
+ , declarations :: [Declaration]
+ , definitionSiteMap :: DefinitionSiteMap
+ -- ^ Definition site of each top-level value, type, and type class instance
+ , externalIds :: [ExternalIdentifierInfo]
+ } deriving (Show, Eq, Generic, Data)
+
+type ExpressionInfoMap = IVM.IntervalMap (Int, Int) ExpressionInfo
+type IdentifierOccurrenceMap = IM.IntMap [((Int, Int), IdentifierOccurrence)]
+type IdentifierInfoMap = HM.HashMap InternalId IdentifierInfo
+
+data DefinitionSiteMap = DefinitionSiteMap
+ { values :: HM.HashMap OccName DefinitionSite
+ , types :: HM.HashMap OccName DefinitionSite
+ , instances :: HM.HashMap T.Text DefinitionSite
+ } deriving (Show, Eq, Generic, Data)
+
+data DefinitionSite = DefinitionSite
+ { location :: LocationInfo
+ , documentation :: Maybe HTML
+ } deriving (Show, Eq, Generic, Data)
+
+type HTML = T.Text
+
+newtype OccName = OccName
+ { getOccName :: T.Text
+ } deriving (Show, Eq, Ord, Generic, A.ToJSONKey, Data, Hashable)
+
+-- | 'CompactModuleInfo' contains a subset of fields of 'ModuleInfo'.
+data CompactModuleInfo = CompactModuleInfo
+ { id :: HaskellModulePath
+ , name :: HaskellModuleName
+ , exprInfoMap :: ExpressionInfoMap
+ , definitionSiteMap :: DefinitionSiteMap
+ , source :: V.Vector T.Text
+ } deriving (Show, Eq, Generic, Data)
+
+haskellPreprocessorExtensions :: [FilePath]
+haskellPreprocessorExtensions =
+ [".hsc", ".chs", ".cpphs", ".gc", ".x", ".y", ".ly"]
+
+toCompactPackageInfo :: PackageInfo ModuleInfo -> PackageInfo CompactModuleInfo
+toCompactPackageInfo PackageInfo {..} =
+ PackageInfo
+ { id = id
+ , moduleMap = HM.map toCompactModuleInfo moduleMap
+ , moduleNameMap = moduleNameMap
+ , directoryTree = directoryTree
+ , externalIdOccMap = externalIdOccMap
+ , externalIdInfoMap = externalIdInfoMap
+ }
+
+toCompactModuleInfo :: ModuleInfo -> CompactModuleInfo
+toCompactModuleInfo ModuleInfo {..} =
+ CompactModuleInfo
+ { id = id
+ , name = name
+ , exprInfoMap = exprInfoMap
+ , definitionSiteMap = definitionSiteMap
+ , source = source
+ }
+
+newtype HaskellModuleName = HaskellModuleName
+ { getHaskellModuleName :: T.Text
+ } deriving (Show, Eq, Ord, Generic, A.ToJSONKey, Data)
+
+newtype HaskellModulePath = HaskellModulePath
+ { getHaskellModulePath :: T.Text
+ } deriving (Show, Eq, Ord, Generic, A.ToJSONKey, Data)
+
+newtype HaskellFilePath = HaskellFilePath
+ { getHaskellFilePath :: T.Text
+ } deriving (Show, Eq, Ord, Generic, A.ToJSONKey, Data)
+
+-- | Haskell identifier (value or type)
+data IdentifierInfo = IdentifierInfo
+ { sort :: NameSort
+ , occName :: OccName
+ , demangledOccName :: T.Text
+ , nameSpace :: NameSpace
+ , locationInfo :: LocationInfo
+ , idType :: Type
+ , details :: Maybe IdDetails
+ , doc :: Maybe HTML
+ , internalId :: InternalId
+ , externalId :: Maybe ExternalId
+ , isExported :: Bool
+ } deriving (Show, Eq, Ord, Generic, Data)
+
+data NameSort
+ = External
+ | Internal
+ deriving (Show, Eq, Ord, Generic, Data)
+
+data NameSpace
+ = VarName
+ | DataName
+ | TvName
+ | TcClsName
+ deriving (Show, Eq, Ord, Generic, Data)
+
+data IdDetails
+ = VanillaId
+ | RecSelId
+ | RecSelIdNaughty
+ | DataConWorkId
+ | DataConWrapId
+ | ClassOpId
+ | PrimOpId
+ | FCallId
+ | TickBoxOpId
+ | DFunId
+ | CoVarId
+ | JoinId
+ deriving (Show, Eq, Ord, Generic, Data)
+
+-- | Each Haskell identifier has an 'InternalId' that is unique within a single module
+newtype InternalId = InternalId
+ { getInternalId :: T.Text
+ } deriving (Show, Eq, Ord, Generic, Data, Hashable, A.ToJSONKey)
+
+newtype ExternalId = ExternalId
+ { getExternalId :: T.Text
+ } deriving (Show, Eq, Ord, Generic, Data, Hashable, A.ToJSONKey)
+
+newtype ExternalIdentifierInfo = ExternalIdentifierInfo
+ { getIdentifierInfo :: IdentifierInfo
+ } deriving (Eq, Show, Generic, Data)
+
+instance Ord ExternalIdentifierInfo where
+ compare (ExternalIdentifierInfo i1) (ExternalIdentifierInfo i2) =
+ case compare
+ (T.length . demangledOccName $ i1)
+ (T.length . demangledOccName $ i2) of
+ GT -> GT
+ LT -> LT
+ EQ ->
+ case compare (demangledOccName i1) (demangledOccName i2) of
+ GT -> GT
+ LT -> LT
+ EQ ->
+ compare
+ (internalId (i1 :: IdentifierInfo))
+ (internalId (i2 :: IdentifierInfo))
+
+data ExpressionInfo = ExpressionInfo
+ { description :: T.Text
+ , exprType :: Maybe Type
+ } deriving (Show, Eq, Generic, Data)
+
+-- | Occurrence of an identifier in a source code
+data IdentifierOccurrence = IdentifierOccurrence
+ { internalId :: Maybe InternalId
+ , internalIdFromRenamedSource :: Maybe InternalId
+ , isBinder :: Bool
+ , instanceResolution :: Maybe InstanceResolution
+ , idOccType :: Maybe Type
+ -- ^ Instantiated type of an identifier
+ , typeArguments :: Maybe [Type]
+ , description :: T.Text
+ , sort :: IdentifierOccurrenceSort
+ } deriving (Show, Eq, Ord, Generic, Data)
+
+data IdentifierOccurrenceSort
+ = ValueId
+ | TypeId
+ | ModuleId LocationInfo
+ deriving (Show, Eq, Ord, Generic, Data)
+
+data Type = Type
+ { components :: [TypeComponent]
+ , componentsExpanded :: Maybe [TypeComponent]
+ -- ^ Components of a type with all type synonyms expanded
+ } deriving (Show, Eq, Ord, Generic, Data)
+
+data TypeComponent
+ = Text T.Text
+ | TyCon { internalId :: InternalId
+ , name :: T.Text }
+ deriving (Show, Eq, Ord, Generic, Data)
+
+-- | Tree of instances
+data InstanceResolution =
+ Instance
+ { name :: T.Text
+ -- ^ Type of an instance, e.g., "instance Show a => ClassName a"
+ , instanceType :: Type
+ , types :: [Type]
+ -- ^ Types at which type variables of a class are instantiated
+ , location :: LocationInfo
+ , instances :: [InstanceResolution]
+ }
+ | Stop
+ deriving (Show,Eq,Ord,Generic,Data)
+
+data SourceCodeTransformation = SourceCodeTransformation
+ { totalLines :: Int
+ , filePath :: HaskellModulePath
+ , linePragmas :: S.Set LinePragma
+ , fileIndex :: HM.HashMap HaskellFilePath (S.Set FileLocation)
+ -- ^ Map from an original filename to its locations in a preprocessed source code
+ } deriving (Show, Eq, Generic, Data)
+
+-- | Location of a file included by a preprocessor
+data FileLocation = FileLocation
+ { lineStart :: Int
+ , lineEnd :: Int
+ , offset :: Int
+ -- ^ (line number in a preprocessed file) - (line number in an original file) + 1
+ } deriving (Show, Eq, Generic, Data)
+
+-- | Line pragma inserted by a preprocessor
+data LinePragma = LinePragma
+ { filePath :: HaskellFilePath
+ , lineNumberPreprocessed :: Int
+ , lineNumberOriginal :: Int
+ } deriving (Show, Eq, Generic, Data)
+
+fromOriginalLineNumber ::
+ SourceCodeTransformation -> (HaskellFilePath, Int) -> Either T.Text Int
+fromOriginalLineNumber SourceCodeTransformation {linePragmas = pragmas} (_originalFileName, originalLineNumber)
+ | S.null pragmas = Right originalLineNumber
+fromOriginalLineNumber SourceCodeTransformation {fileIndex = index} (originalFileName, originalLineNumber) =
+ case HM.lookup originalFileName index of
+ Just set ->
+ -- lookupGE finds smallest element greater or equal to the given one
+ case S.lookupGE (FileLocation 1 originalLineNumber 1) set of
+ Just FileLocation {..} -> Right $ originalLineNumber + offset
+ Nothing ->
+ Left $
+ T.concat
+ [ "Cannot find "
+ , T.pack . show $ (originalFileName, originalLineNumber)
+ , " in "
+ , T.pack $ show index
+ ]
+ Nothing ->
+ Left $
+ T.concat
+ [ "Cannot find file "
+ , T.pack . show $ originalFileName
+ , " in "
+ , T.pack $ show index
+ ]
+
+data Declaration = Declaration
+ { sort :: DeclarationSort
+ , name :: T.Text
+ , declType :: Maybe Type
+ , isExported :: Bool
+ , lineNumber :: Int
+ } deriving (Show, Eq, Ord, Generic, Data)
+
+data DeclarationSort
+ = TyClD
+ | InstD
+ | ValD
+ | ForD
+ deriving (Show, Eq, Ord, Generic, Data)
+
+data LocationInfo
+ = ExactLocation { packageId :: PackageId
+ , modulePath :: HaskellModulePath
+ , moduleName :: HaskellModuleName
+ , startLine :: Int
+ , endLine :: Int
+ , startColumn :: Int
+ , endColumn :: Int }
+ | ApproximateLocation { packageId :: PackageId
+ , moduleName :: HaskellModuleName
+ , entity :: LocatableEntity
+ , name :: T.Text
+ , haddockAnchorId :: Maybe T.Text
+ , componentId :: ComponentId }
+ | UnknownLocation T.Text
+ deriving (Show, Eq, Ord, Generic, Data)
+
+data LocatableEntity
+ = Typ
+ | Val
+ | Inst
+ | Mod
+ deriving (Show, Eq, Ord, Generic, Data)
+
+--------------------------------------------------------------------------------
+-- Instances
+--------------------------------------------------------------------------------
+
+deriving instance (Data k) => Data (IVM.Interval k)
+
+instance (Data k, Data v, Eq k, Ord k, Data (IVM.Interval k)) =>
+ Data (IVM.IntervalMap k v) where
+ gfoldl f z m = z IVM.fromList `f` IVM.toList m
+ toConstr _ = fromListConstr
+ gunfold k z c =
+ case constrIndex c of
+ 1 -> k (z IVM.fromList)
+ _ -> error "gunfold"
+ dataTypeOf _ = intervalMapDataType
+ dataCast2 = gcast2
+
+fromListConstr :: Constr
+fromListConstr = mkConstr intervalMapDataType "fromList" [] Prefix
+
+intervalMapDataType :: DataType
+intervalMapDataType = mkDataType "Data.IntervalMap" [fromListConstr]
+
+deriving instance Generic (IVM.Interval k)
+
+instance Hashable HaskellModuleName
+instance Serialize HaskellModuleName
+instance Hashable HaskellModulePath
+instance Serialize HaskellModulePath
+instance Hashable HaskellFilePath
+instance Serialize HaskellFilePath
+instance (Serialize k, Serialize v, Ord k) =>
+ Serialize (IVM.IntervalMap k v) where
+ put = put . IVM.toAscList
+ get = IVM.fromAscList <$> Data.Serialize.get
+instance Ord LinePragma where
+ compare p1 p2 =
+ compare
+ (lineNumberPreprocessed (p1 :: LinePragma))
+ (lineNumberPreprocessed (p2 :: LinePragma))
+instance Ord FileLocation where
+ compare l1 l2 = compare (lineEnd l1) (lineEnd l2)
+instance Serialize LinePragma
+instance Serialize FileLocation
+instance Serialize SourceCodeTransformation
+instance Serialize IdentifierInfo
+instance Serialize InternalId
+instance Serialize ExternalId
+instance Serialize ExternalIdentifierInfo where
+ put (ExternalIdentifierInfo info) = put info
+ get = ExternalIdentifierInfo <$>(get :: Get IdentifierInfo)
+instance Serialize InstanceResolution
+instance Serialize OccName
+instance Serialize IdDetails
+instance Serialize NameSpace
+instance Serialize DefinitionSiteMap
+instance Serialize DefinitionSite
+instance Serialize Declaration
+instance Serialize NameSort
+instance Serialize DeclarationSort
+instance Serialize PackageId
+instance Serialize Data.Version.Version
+instance Serialize (PackageInfo ModuleInfo)
+instance Serialize (PackageInfo CompactModuleInfo)
+instance Serialize IdentifierSrcSpan
+instance Serialize DirTree
+instance Serialize ComponentId
+instance Serialize ComponentType
+instance Serialize T.Text where
+ put = put . encodeUtf8
+ get = decodeUtf8 <$> Data.Serialize.get
+instance (Serialize k, Serialize v, Eq k,Hashable k) => Serialize (HM.HashMap k v) where
+ put = put . HM.toList
+ get = HM.fromList <$> get
+instance Serialize ModuleInfo
+instance Serialize CompactModuleInfo
+instance (Serialize k) => Serialize (IVM.Interval k)
+instance Serialize LocationInfo
+instance Serialize IdentifierOccurrence
+instance Serialize IdentifierOccurrenceSort
+instance Serialize TypeComponent
+instance (Serialize a) => Serialize (V.Vector a) where
+ put = put . V.toList
+ get = V.fromList <$> get
+instance Serialize Type
+instance Serialize ExpressionInfo
+instance Serialize LocatableEntity
+instance (Serialize k,Ord k,Serialize v,Ord v,Hashable k) => Serialize (Trie k v)
+instance NFData HaskellModuleName
+instance NFData HaskellModulePath
+instance NFData HaskellFilePath
+instance NFData LinePragma
+instance NFData FileLocation
+instance NFData SourceCodeTransformation
+instance NFData IdentifierInfo
+instance NFData InternalId
+instance NFData ExternalId
+instance NFData ExternalIdentifierInfo
+instance NFData InstanceResolution
+instance NFData IdDetails
+instance NFData NameSpace
+instance NFData OccName
+instance NFData DefinitionSiteMap
+instance NFData DefinitionSite
+instance NFData Declaration
+instance NFData NameSort
+instance NFData DeclarationSort
+instance NFData PackageId
+instance NFData (PackageInfo ModuleInfo)
+instance NFData (PackageInfo CompactModuleInfo)
+instance NFData IdentifierSrcSpan
+instance NFData DirTree
+instance NFData ComponentId
+instance NFData ComponentType
+instance NFData ModuleInfo
+instance NFData CompactModuleInfo
+instance NFData LocationInfo
+instance NFData IdentifierOccurrence
+instance NFData IdentifierOccurrenceSort
+instance NFData TypeComponent
+instance NFData Type
+instance NFData ExpressionInfo
+instance NFData LocatableEntity
+instance (NFData k, Ord k, NFData v, Ord v, Hashable k) =>
+ NFData (Trie k v)
+
+omitNothingOptions :: Options
+omitNothingOptions = defaultOptions {omitNothingFields = True}
+
+instance A.ToJSON (PackageInfo a) where
+ toJSON PackageInfo {..} =
+ A.object
+ [ ("id", A.toJSON $ packageIdToText id)
+ , ("directoryTree", A.toJSON directoryTree)
+ , ("modules", A.toJSON . HM.map (const ()) $ moduleMap)
+ ]
+
+instance A.ToJSON ModuleInfo where
+ toJSON ModuleInfo {..} =
+ let sourceCodeLines = zip [1 ..] $ V.toList source
+ tokenizedLines =
+ L.map
+ (\(lineNumber, lineText) ->
+ case IM.lookup lineNumber idOccMap of
+ Just identifiers -> (lineNumber, tokenize lineText identifiers)
+ Nothing ->
+ ( lineNumber
+ , [(lineText, (1, T.length lineText + 1), Nothing)]))
+ sourceCodeLines
+ html =
+ Html.table Html.! Attr.class_ "source-code" $
+ Html.tbody $ mapM_ (uncurry lineToHtml) tokenizedLines
+ in A.object
+ [ ("id", A.toJSON id)
+ , ("name", A.toJSON name)
+ , ("sourceCodeHtml", A.toJSON . renderHtml $ html)
+ , ("identifiers", A.toJSON idInfoMap)
+ , ("occurrences", A.toJSON $ idOccurrencesHashMap idOccMap)
+ , ("declarations", A.toJSON declarations)
+ ]
+
+idOccurrencesHashMap ::
+ IM.IntMap [((Int, Int), IdentifierOccurrence)]
+ -> HM.HashMap T.Text IdentifierOccurrence
+idOccurrencesHashMap =
+ HM.fromList .
+ concatMap
+ (\(lineNum, occs) ->
+ L.map
+ (\((startCol, endCol), occ) ->
+ (occurrenceLocationToText lineNum startCol endCol, occ))
+ occs) .
+ IM.toList
+
+idOccurrenceList ::
+ IM.IntMap [((Int, Int), IdentifierOccurrence)]
+ -> HM.HashMap T.Text IdentifierOccurrence
+idOccurrenceList =
+ HM.fromList .
+ concatMap
+ (\(lineNum, occs) ->
+ L.map
+ (\((startCol, endCol), occ) ->
+ (occurrenceLocationToText lineNum startCol endCol, occ))
+ occs) .
+ IM.toList
+
+occurrenceLocationToText :: Int -> Int -> Int -> T.Text
+occurrenceLocationToText lineNum startCol endCol =
+ T.concat
+ [ T.pack . show $ lineNum
+ , "-"
+ , T.pack . show $ startCol
+ , "-"
+ , T.pack . show $ endCol
+ ]
+
+lineToHtml :: Int
+ -> [(T.Text, (Int, Int), Maybe IdentifierOccurrence)]
+ -> Html.Html
+lineToHtml lineNumber tokens =
+ Html.tr $ do
+ Html.td Html.! Attr.class_ "line-number" Html.!
+ Attr.id (Html.textValue . T.append "LN" . T.pack $ show lineNumber) $
+ Html.toHtml (T.pack $ show lineNumber)
+ Html.td Html.! Attr.class_ "line-content" Html.!
+ Html.dataAttribute "line" (Html.textValue $ T.pack . show $ lineNumber) Html.!
+ Attr.id (Html.textValue . T.append "LC" . T.pack $ show lineNumber) $
+ mapM_
+ (\(content, (start, end), mbIdOcc) ->
+ let addPositionAttrs :: Html.Html -> Html.Html
+ addPositionAttrs htmlElement =
+ htmlElement Html.!
+ Html.dataAttribute
+ "start"
+ (Html.textValue $ T.pack . show $ start) Html.!
+ Html.dataAttribute "end" (Html.textValue $ T.pack . show $ end)
+ in case mbIdOcc of
+ Just idOcc ->
+ addPositionAttrs $
+ Html.span Html.! Attr.class_ "identifier" Html.!
+ Attr.id
+ (Html.textValue .
+ maybe "" getInternalId . internalIdFromRenamedSource $
+ idOcc) Html.!
+ Html.dataAttribute
+ "occurrence"
+ (Html.textValue $
+ occurrenceLocationToText lineNumber start end) Html.!
+ Html.dataAttribute
+ "identifier"
+ (Html.textValue $
+ maybe "" getInternalId $
+ internalId (idOcc :: IdentifierOccurrence)) $
+ Html.toHtml content
+ Nothing -> addPositionAttrs . Html.span . Html.toHtml $ content)
+ tokens
+
+tokenize
+ :: forall a.
+ T.Text -- ^ Source code
+ -> [((Int, Int), a)] -- ^ Identifier locations
+ -- The end position is defined to be the column /after/ the end of the
+ -- span. That is, a span of (1,1)-(1,2) is one character long, and a
+ -- span of (1,1)-(1,1) is zero characters long.
+ -> [(T.Text, (Int, Int), Maybe a)]
+tokenize line =
+ L.reverse .
+ (\(remainingLine, currentIndex, c) ->
+ if T.null remainingLine
+ then c
+ else (remainingLine, (currentIndex, T.length line + 1), Nothing) : c) .
+ L.foldl' split (line, 1, [])
+ where
+ split ::
+ (T.Text, Int, [(T.Text, (Int, Int), Maybe a)])
+ -> ((Int, Int), a)
+ -> (T.Text, Int, [(T.Text, (Int, Int), Maybe a)])
+ split (remainingLine, currentIndex, chunks) ((start, end), a)
+ | start == currentIndex =
+ let (chunk, remainingLine') = T.splitAt (end - start) remainingLine
+ chunks' = (chunk, (start, end), Just a) : chunks
+ in (remainingLine', end, chunks')
+ | otherwise =
+ let (chunkNoId, remainingLine') =
+ T.splitAt (start - currentIndex) remainingLine
+ (chunk, remainingLine'') = T.splitAt (end - start) remainingLine'
+ in ( remainingLine''
+ , end
+ , (chunk, (start, end), Just a) :
+ (chunkNoId, (currentIndex, start), Nothing) : chunks)
+
+docToHtml ::
+ forall mod id.
+ (mod -> Html.Html)
+ -> (id -> Html.Html)
+ -> DocH mod id
+ -> HTML
+docToHtml modToHtml idToHtml = toStrict . renderHtml . toH
+ where
+ toH :: DocH mod id -> Html.Html
+ toH (DocAppend doc1 doc2) = toH doc1 >> toH doc2
+ toH (DocParagraph doc) = Html.p $ toH doc
+ toH (DocIdentifier identifier) = Html.span $ idToHtml identifier
+ toH (DocWarning doc) = Html.div Html.! Attr.class_ "warning" $ toH doc
+ toH (DocEmphasis doc) = Html.em $ toH doc
+ toH DocEmpty = mempty
+ toH (DocBold doc) = Html.b $ toH doc
+ toH (DocMonospaced doc) =
+ Html.span Html.! Attr.class_ "source-code-font" $ toH doc
+ toH (DocUnorderedList docs) = Html.ul $ mapM_ (Html.li . toH) docs
+ toH (DocOrderedList docs) = Html.ol $ mapM_ (Html.li . toH) docs
+ toH (DocDefList docs) =
+ Html.dl $
+ mapM_ (\(doc1, doc2) -> Html.dt (toH doc1) >> Html.dd (toH doc2)) docs
+ toH (DocCodeBlock doc) = Html.div Html.! Attr.class_ "source-code" $ toH doc
+ toH (DocIdentifierUnchecked modName) = modToHtml modName
+ toH (DocModule str) = Html.span . Html.toHtml . T.pack $ str
+ toH (DocHyperlink (Hyperlink url mbTitle)) =
+ Html.a Html.! (Attr.href . Html.textValue . T.pack $ url) $
+ Html.toHtml $ fromMaybe url mbTitle
+ toH (DocPic (Picture uri mbTitle)) =
+ Html.img Html.! (Attr.src . Html.textValue . T.pack $ uri) Html.!
+ (Attr.title . Html.textValue . T.pack $ fromMaybe "" mbTitle)
+ toH (DocMathInline str) =
+ Html.span . Html.toHtml $ T.pack ("\\(" ++ str ++ "\\)")
+ toH (DocMathDisplay str) =
+ Html.div . Html.toHtml $ T.pack ("\\[" ++ str ++ "\\]")
+ toH (DocAName str) =
+ Html.a Html.! (Attr.id . Html.textValue . T.pack $ str) $ mempty
+ toH (DocProperty str) =
+ Html.div Html.! Attr.class_ "source-code" $ Html.toHtml $ T.pack str
+ toH (DocExamples examples) =
+ Html.div Html.! Attr.class_ "source-code" $
+ mapM_
+ (\(Example expr results) ->
+ let htmlPrompt = Html.span $ Html.toHtml (">>> " :: String)
+ htmlExpression = Html.span $ Html.toHtml (expr ++ "\n")
+ in htmlPrompt >> htmlExpression >>
+ mapM_ (Html.span . Html.toHtml) (unlines results))
+ examples
+ toH (DocString str) = Html.span . Html.toHtml $ T.pack str
+ toH (DocHeader (Header level doc)) = toHeader level $ toH doc
+ where
+ toHeader 1 = Html.h1
+ toHeader 2 = Html.h2
+ toHeader 3 = Html.h3
+ toHeader 4 = Html.h4
+ toHeader 5 = Html.h5
+ toHeader _ = Html.h6
+
+instance A.ToJSON HaskellModuleName where
+ toJSON (HaskellModuleName name) = A.String name
+instance A.ToJSON HaskellModulePath where
+ toJSON (HaskellModulePath path) = A.String path
+instance A.ToJSON HaskellFilePath where
+ toJSON (HaskellFilePath path) = A.String path
+instance A.ToJSON LinePragma where
+ toJSON = A.genericToJSON omitNothingOptions
+instance A.ToJSON FileLocation where
+ toJSON = A.genericToJSON omitNothingOptions
+instance A.ToJSON IdentifierInfo where
+ toJSON = A.genericToJSON omitNothingOptions
+instance A.ToJSON InternalId where
+ toJSON (InternalId text) = A.toJSON text
+instance A.ToJSON ExternalId where
+ toJSON (ExternalId text) = A.toJSON text
+instance A.ToJSON ExternalIdentifierInfo where
+ toJSON (ExternalIdentifierInfo info) = A.toJSON info
+instance A.ToJSON InstanceResolution where
+ toJSON (Instance name typ types location instances) =
+ A.object
+ [ "name" A..= A.toJSON name
+ , "types" A..= A.toJSON types
+ , "location" A..= A.toJSON location
+ , "instanceType" A..= A.toJSON typ
+ , "instances" A..=
+ (A.Array . V.fromList . Prelude.map A.toJSON $ instances)
+ ]
+ toJSON Stop = A.Null
+instance A.ToJSON IdDetails where
+ toJSON = A.genericToJSON omitNothingOptions
+instance A.ToJSON NameSpace where
+ toJSON = A.genericToJSON omitNothingOptions
+instance A.ToJSON Declaration
+instance A.ToJSON NameSort
+instance A.ToJSON OccName where
+ toJSON (OccName name) = A.String name
+instance A.ToJSON DeclarationSort
+instance A.ToJSON PackageId
+instance A.ToJSON ComponentId where
+ toJSON (ComponentId id) = A.toJSON id
+instance A.ToJSON ComponentType
+instance A.ToJSON LocationInfo where
+ toJSON = A.genericToJSON omitNothingOptions
+instance A.ToJSON LocatableEntity
+instance A.ToJSON IdentifierOccurrence where
+ toJSON IdentifierOccurrence {..} =
+ A.object $
+ [("sort", A.toJSON sort)] ++
+ [("description", A.toJSON description)] ++
+ [("internalId", A.toJSON internalId) | isJust internalId] ++
+ [("isBinder", A.toJSON isBinder) | isBinder] ++
+ [("instanceResolution", A.toJSON instanceResolution) | isJust instanceResolution] ++
+ [("idOccType", A.toJSON idOccType) | isJust idOccType]
+instance A.ToJSON IdentifierOccurrenceSort
+instance A.ToJSON TypeComponent where
+ toJSON = A.genericToJSON omitNothingOptions
+instance A.ToJSON Type where
+ toJSON = A.genericToJSON omitNothingOptions
+instance A.ToJSON ExpressionInfo where
+ toJSON = A.genericToJSON omitNothingOptions
+instance A.ToJSON DirTree
+instance A.ToJSON DefinitionSite where
+ toJSON = A.genericToJSON omitNothingOptions
+instance A.ToJSON IdentifierSrcSpan
+instance A.ToJSON (IVM.Interval (Int, Int)) where
+ toJSON (IVM.IntervalCO a b) = intervalToValue a b
+ toJSON (IVM.ClosedInterval a b) = intervalToValue a b
+ toJSON (IVM.OpenInterval a b) = intervalToValue a b
+ toJSON (IVM.IntervalOC a b) = intervalToValue a b
+
+intervalToValue :: (Int, Int) -> (Int, Int) -> A.Value
+intervalToValue (l1, c1) (l2, c2) =
+ A.object
+ [ ("start", A.object [("line", A.toJSON l1), ("column", A.toJSON c1)])
+ , ("end", A.object [("line", A.toJSON l2), ("column", A.toJSON c2)])
+ ]
+
+data SourceCodePreprocessing
+ = AfterPreprocessing
+ | BeforePreprocessing
+ deriving (Show, Eq)
+
+data Log
+ = StdOut
+ | ToFile FilePath
+ deriving (Show, Eq)
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-20 18:53:13 +0000