diff options
Diffstat (limited to 'src/HaskellCodeExplorer')
| -rw-r--r-- | src/HaskellCodeExplorer/AST/RenamedSource.hs | 498 | ||||
| -rw-r--r-- | src/HaskellCodeExplorer/AST/TypecheckedSource.hs | 1231 | ||||
| -rw-r--r-- | src/HaskellCodeExplorer/GhcUtils.hs | 1122 | ||||
| -rw-r--r-- | src/HaskellCodeExplorer/ModuleInfo.hs | 811 | ||||
| -rw-r--r-- | src/HaskellCodeExplorer/PackageInfo.hs | 595 | ||||
| -rw-r--r-- | src/HaskellCodeExplorer/Preprocessor.hs | 159 | ||||
| -rw-r--r-- | src/HaskellCodeExplorer/Types.hs | 880 |
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) |