diff options
| -rw-r--r-- | app/Indexer.hs | 1 | ||||
| -rw-r--r-- | app/Server.hs | 144 | ||||
| -rw-r--r-- | app/Store.hs | 1 | ||||
| -rw-r--r-- | hcel.cabal | 1 | ||||
| -rw-r--r-- | src/HaskellCodeExplorer/AST/TypecheckedSource.hs | 1 | ||||
| -rw-r--r-- | src/HaskellCodeExplorer/PackageInfo.hs | 16 | ||||
| -rw-r--r-- | src/HaskellCodeExplorer/Types.hs | 80 |
7 files changed, 89 insertions, 155 deletions
diff --git a/app/Indexer.hs b/app/Indexer.hs index 1c32f89..c145b2a 100644 --- a/app/Indexer.hs +++ b/app/Indexer.hs @@ -18,7 +18,6 @@ import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSC import qualified Data.HashMap.Strict as HM import Data.Maybe ( fromMaybe ) -import Data.Semigroup ( (<>) ) import qualified Data.Serialize as S import qualified Data.Text as T import qualified Data.Text.Encoding as TE diff --git a/app/Server.hs b/app/Server.hs index 07f1e45..1a8a788 100644 --- a/app/Server.hs +++ b/app/Server.hs @@ -524,14 +524,11 @@ createStore storePath config = do (\(errors, packageMap, packagePathMap, packageVersions, globalReferenceMap, globalIdentifiers, index) path -> do eitherPackageInfo <- loadPackageInfo config path case eitherPackageInfo of - Right (packageInfo, packagePath) -> do - let packageId = - HCE.id - (packageInfo :: HCE.PackageInfo HCE.CompactModuleInfo) - addPackageInfo :: StateT Store.State IO () + Right (packageInfo@HCE.PackageInfo{id = packageId, ..}, packagePath) -> do + let addPackageInfo :: StateT Store.State IO () addPackageInfo = do Store.add - (HCE.moduleNameMap packageInfo) + moduleNameMap ( packageId , Proxy :: Proxy (HM.HashMap HCE.HaskellModuleName (HM.HashMap HCE.ComponentId HCE.HaskellModulePath))) addExternalIdInfo packageId packageInfo @@ -542,27 +539,24 @@ createStore storePath config = do ( packageId , extId , Proxy :: Proxy (S.Set HCE.IdentifierSrcSpan))) - (HM.toList $ HCE.externalIdOccMap packageInfo) + (HM.toList externalIdOccMap) mapM_ - (\(modulePath, moduleInfo) -> do + (\(modulePath, HCE.CompactModuleInfo {id = _, ..}) -> do addExpressionInfo packageId modulePath - (HCE.exprInfoMap - (moduleInfo :: HCE.CompactModuleInfo)) + exprInfoMap Store.add - (HCE.definitionSiteMap - (moduleInfo :: HCE.CompactModuleInfo)) + definitionSiteMap ( packageId , modulePath , Proxy :: Proxy HCE.DefinitionSiteMap) Store.add - (HCE.source (moduleInfo :: HCE.CompactModuleInfo)) + source ( packageId , modulePath , Proxy :: Proxy (V.Vector T.Text))) . - HM.toList $ - HCE.moduleMap packageInfo + HM.toList $ moduleMap index' <- Store.writeValues fileHandle index addPackageInfo print $ T.unpack (HCE.packageIdToText packageId) return $ @@ -608,7 +602,7 @@ createStore storePath config = do ([], HM.empty, HM.empty, [], HM.empty, [], M.empty) packageDirectories let versions = - L.sortOn (T.toLower . (name :: PackageVersions -> T.Text)) . + L.sortOn (T.toLower . (\(PackageVersions name _) -> name)) . map (\(name, vers) -> PackageVersions name (L.sortOn Down vers)) . HM.toList . HM.fromListWith (++) $ packageVersions' @@ -779,7 +773,7 @@ loadPackages config _ = do packageLoadErrors = lefts result packageInfos = map fst loadedPackages packageIds = - map (HCE.id :: HCE.PackageInfo modInfo -> HCE.PackageId) packageInfos + map (\HCE.PackageInfo{id = packageId} -> packageId) packageInfos unless (null packageInfos) $ do putStrLn "Loaded packages : " mapM_ (print . HCE.packageIdToText) packageIds @@ -789,7 +783,7 @@ loadPackages config _ = do if not . null $ loadedPackages then do let packageVersions = - L.sortOn (T.toLower . (name :: PackageVersions -> T.Text)) . + L.sortOn (T.toLower . (\(PackageVersions name _) -> name)) . map (\(name, versions) -> PackageVersions name (L.sortOn Down versions)) . @@ -807,30 +801,23 @@ loadPackages config _ = do packageInfos packagePathMap = L.foldl' - (\hMap (packageInfo, path) -> + (\hMap (HCE.PackageInfo{id = packageId}, path) -> let key = - PackageId $ - HCE.packageIdToText - (HCE.id - (packageInfo :: HCE.PackageInfo HCE.CompactModuleInfo)) + PackageId $ HCE.packageIdToText packageId in HM.insert key path hMap) HM.empty loadedPackages globalReferenceMap = L.foldl' - (\hMap (packageInfo, _path) -> + (\hMap (HCE.PackageInfo{id = packageId, ..}, _path) -> let references = HM.map (\spans -> S.singleton (GlobalReferences (S.size spans) - (HCE.packageIdToText packageId))) . - HCE.externalIdOccMap $ - packageInfo - packageId = - HCE.id - (packageInfo :: HCE.PackageInfo HCE.CompactModuleInfo) + (HCE.packageIdToText packageId))) + externalIdOccMap in HM.unionWith S.union references hMap) HM.empty loadedPackages @@ -867,13 +854,9 @@ loadPackages config _ = do else return Nothing where packageName :: HCE.PackageInfo HCE.CompactModuleInfo -> PackageName - packageName = - PackageName . - (HCE.name :: HCE.PackageId -> T.Text) . - (HCE.id :: HCE.PackageInfo modInfo -> HCE.PackageId) + packageName (HCE.PackageInfo {id = pkgId}) = PackageName $ HCE.packageIdToText pkgId packageVersion :: HCE.PackageInfo HCE.CompactModuleInfo -> Version - packageVersion = - HCE.version . (HCE.id :: HCE.PackageInfo modInfo -> HCE.PackageId) + packageVersion (HCE.PackageInfo {id = HCE.PackageId _ version}) = version trieValues :: HCE.Trie k v -> [v] trieValues (HCE.Trie values children) = @@ -1101,9 +1084,8 @@ getExpressions packageId modulePath startLine startColumn endLine endColumn = do requestedInterval in case packageInfo' of PackageInfo packageInfo -> - withModuleInfo packageInfo modulePath $ \modInfo -> do - let exprInfoMap = - HCE.exprInfoMap (modInfo :: HCE.CompactModuleInfo) + withModuleInfo packageInfo modulePath $ + \HCE.CompactModuleInfo{exprInfoMap = exprInfoMap} -> findInterval exprInfoMap PackageInfoStore pId store -> do let topLevelExprKey = @@ -1143,7 +1125,7 @@ getDefinitionSite packageId componentId modName entity name' = HCE.PackageId -> HCE.DefinitionSiteMap -> ReaderT Environment IO HCE.DefinitionSite - findDefSite pId defSiteMap = + findDefSite pId HCE.DefinitionSiteMap{..} = case entity of HCE.Mod -> return $ @@ -1154,16 +1136,9 @@ getDefinitionSite packageId componentId modName entity name' = let mbDefinitionSite = let name = fixDots name' in case entity of - HCE.Typ -> - HM.lookup (HCE.OccName name) $ - HCE.types (defSiteMap :: HCE.DefinitionSiteMap) - HCE.Val -> - HM.lookup (HCE.OccName name) $ - HCE.values (defSiteMap :: HCE.DefinitionSiteMap) - HCE.Inst -> - HM.lookup name $ - HCE.instances (defSiteMap :: HCE.DefinitionSiteMap) - _ -> Nothing + HCE.Typ -> HM.lookup (HCE.OccName name) types + HCE.Val -> HM.lookup (HCE.OccName name) values + HCE.Inst -> HM.lookup name instances case mbDefinitionSite of Just definitionSite -> return definitionSite Nothing -> @@ -1177,18 +1152,12 @@ getDefinitionSite packageId componentId modName entity name' = , toLazyBS $ HCE.getHaskellModulePath modPath ] in case packageInfo' of - PackageInfo packageInfo -> - let pId = - HCE.id - (packageInfo :: HCE.PackageInfo HCE.CompactModuleInfo) - in case HM.lookup - modPath - (HCE.moduleMap - (packageInfo :: HCE.PackageInfo HCE.CompactModuleInfo)) of - Just HCE.CompactModuleInfo {definitionSiteMap = defSiteMap} -> - findDefSite pId defSiteMap - Nothing -> - error404 $ + PackageInfo HCE.PackageInfo{id = pId, ..} -> + case HM.lookup modPath moduleMap of + Just HCE.CompactModuleInfo {definitionSiteMap = defSiteMap} -> + findDefSite pId defSiteMap + Nothing -> + error404 $ BSL.concat [ "Module " , toLazyBS $ HCE.getHaskellModulePath modPath @@ -1315,21 +1284,15 @@ getReferences packageId externalId mbPage mbPerPage = Nothing Nothing refModulePath :: ReferenceWithSource -> HCE.HaskellModulePath - refModulePath = - (HCE.modulePath :: HCE.IdentifierSrcSpan -> HCE.HaskellModulePath) . - idSrcSpan + refModulePath ReferenceWithSource{idSrcSpan = HCE.IdentifierSrcSpan {..}} = modulePath return $ addPaginationHeaders url paginatedReferences totalCount page perPage $ concatMap (\refs -> case refs of - ref:_ -> - let path = - HCE.getHaskellModulePath . - (HCE.modulePath :: HCE.IdentifierSrcSpan -> HCE.HaskellModulePath) . - idSrcSpan $ - ref - in [SourceFile path refs] + ReferenceWithSource{idSrcSpan = HCE.IdentifierSrcSpan {..}}:_ -> + + [SourceFile (HCE.getHaskellModulePath modulePath) refs] _ -> []) $ groupWith refModulePath $ mapMaybe @@ -1359,7 +1322,7 @@ getReferences packageId externalId mbPage mbPerPage = mkReferenceWithSource :: PackageInfo -> [HCE.IdentifierSrcSpan] -> Maybe ReferenceWithSource -mkReferenceWithSource packageInfo' spans@(srcSpan:_) = +mkReferenceWithSource packageInfo' spans@(srcSpan@HCE.IdentifierSrcSpan{line, modulePath}:_) = let mkRef :: Maybe (V.Vector T.Text) -> Maybe ReferenceWithSource mkRef mbSource = case mbSource of @@ -1367,27 +1330,22 @@ mkReferenceWithSource packageInfo' spans@(srcSpan:_) = let sourceCodeHtml = buildHtmlCodeSnippet source - (HCE.line (srcSpan :: HCE.IdentifierSrcSpan)) + line (map - (\HCE.IdentifierSrcSpan {..} -> (startColumn, endColumn)) + (\HCE.IdentifierSrcSpan{startColumn, endColumn} -> (startColumn, endColumn)) spans) in Just $ ReferenceWithSource sourceCodeHtml srcSpan _ -> Just $ ReferenceWithSource "" srcSpan in case packageInfo' of - PackageInfo packageInfo -> do + PackageInfo HCE.PackageInfo{moduleMap} -> do let mbSource = - (HCE.source :: HCE.CompactModuleInfo -> V.Vector T.Text) <$> - HM.lookup - (HCE.modulePath (srcSpan :: HCE.IdentifierSrcSpan)) - (HCE.moduleMap - (packageInfo :: HCE.PackageInfo HCE.CompactModuleInfo)) + (\HCE.CompactModuleInfo{source} -> source) <$> + HM.lookup modulePath moduleMap mkRef mbSource PackageInfoStore packageId store -> do let eitherSourceCode = Store.lookup - ( packageId - , HCE.modulePath (srcSpan :: HCE.IdentifierSrcSpan) - , Proxy :: Proxy (V.Vector T.Text)) + (packageId, modulePath, Proxy :: Proxy (V.Vector T.Text)) store case eitherSourceCode of Right source -> mkRef (Just source) @@ -1667,10 +1625,8 @@ withModuleInfo :: -> HCE.HaskellModulePath -> (HCE.CompactModuleInfo -> ReaderT Environment IO a) -> ReaderT Environment IO a -withModuleInfo packageInfo path action = - case HM.lookup - path - (HCE.moduleMap (packageInfo :: HCE.PackageInfo HCE.CompactModuleInfo)) of +withModuleInfo HCE.PackageInfo{id = pId, moduleMap} path action = + case HM.lookup path moduleMap of Just modInfo -> action modInfo Nothing -> error404 $ @@ -1678,9 +1634,7 @@ withModuleInfo packageInfo path action = [ "Module " , toLazyBS $ HCE.getHaskellModulePath path , " is not found in package " - , toLazyBS $ - HCE.packageIdToText $ - HCE.id (packageInfo :: HCE.PackageInfo HCE.CompactModuleInfo) + , toLazyBS $ HCE.packageIdToText pId ] withModulePath :: @@ -1691,10 +1645,8 @@ withModulePath :: -> ReaderT Environment IO a withModulePath packageInfo' componentId moduleName action = case packageInfo' of - PackageInfo packageInfo -> - case HM.lookup - moduleName - (HCE.moduleNameMap packageInfo) of + PackageInfo HCE.PackageInfo{id = pId, ..} -> + case HM.lookup moduleName moduleNameMap of Just modulePathMap -> case HM.lookup componentId modulePathMap of Just modulePath -> action modulePath @@ -1702,7 +1654,7 @@ withModulePath packageInfo' componentId moduleName action = case HM.lookup (HCE.ComponentId "lib") modulePathMap of Just path -> action path Nothing -> notFoundInComponent - Nothing -> notFoundInPackage (HCE.id (packageInfo :: HCE.PackageInfo HCE.CompactModuleInfo)) + Nothing -> notFoundInPackage pId PackageInfoStore packageId store -> do let eitherModNameMap = Store.lookup diff --git a/app/Store.hs b/app/Store.hs index b0ea4ae..91184a3 100644 --- a/app/Store.hs +++ b/app/Store.hs @@ -21,7 +21,6 @@ import Control.Monad.IO.Class (liftIO) import qualified Control.Monad.State.Strict as S import qualified Data.ByteString as BS import qualified Data.ByteString.Short as BSS -import Data.Either (Either) import qualified Data.Map.Strict as M import Data.Serialize ( Serialize, @@ -124,6 +124,7 @@ executable haskell-code-server , wreq if impl(ghc >= 8.4.3) build-depends: ghc-compact + default-language: Haskell2010 test-suite test default-language: Haskell2010 diff --git a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs index 232d54d..3ca9194 100644 --- a/src/HaskellCodeExplorer/AST/TypecheckedSource.hs +++ b/src/HaskellCodeExplorer/AST/TypecheckedSource.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE StrictData #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module HaskellCodeExplorer.AST.TypecheckedSource ( ASTState(..) diff --git a/src/HaskellCodeExplorer/PackageInfo.hs b/src/HaskellCodeExplorer/PackageInfo.hs index 295f1cb..8e0fbdf 100644 --- a/src/HaskellCodeExplorer/PackageInfo.hs +++ b/src/HaskellCodeExplorer/PackageInfo.hs @@ -13,21 +13,17 @@ module HaskellCodeExplorer.PackageInfo , ghcVersion ) where import Control.DeepSeq ( deepseq ) -import Control.Exception ( IOException - , SomeAsyncException +import Control.Exception ( SomeAsyncException , SomeException , fromException , throw - , try ) import Control.Monad ( foldM , unless , when ) import Control.Monad.Catch ( handle ) -import Control.Monad.Extra ( anyM - , findM - ) +import Control.Monad.Extra ( findM ) import Control.Monad.Logger ( LoggingT(..) , MonadLogger(..) , MonadLoggerIO(..) @@ -120,7 +116,6 @@ import qualified HaskellCodeExplorer.Types as HCE import Prelude hiding ( id ) import System.Directory ( canonicalizePath , doesFileExist - , findExecutable , getCurrentDirectory , getDirectoryContents , makeAbsolute @@ -136,16 +131,9 @@ import System.FilePath ( (</>) , splitDirectories , splitPath , takeBaseName - , takeDirectory , takeExtension , takeFileName ) -import System.FilePath.Find ( (==?) - , always - , fileName - , find - ) -import System.Process ( readProcess ) testCreatePkgInfo :: FilePath -> IO (HCE.PackageInfo HCE.ModuleInfo) testCreatePkgInfo pkgPath = runStdoutLoggingT diff --git a/src/HaskellCodeExplorer/Types.hs b/src/HaskellCodeExplorer/Types.hs index 4c3d5c7..aac890b 100644 --- a/src/HaskellCodeExplorer/Types.hs +++ b/src/HaskellCodeExplorer/Types.hs @@ -94,8 +94,7 @@ 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) +packageName (PackageInfo { id = PackageId name _ }) = name data IdentifierSrcSpan = IdentifierSrcSpan { modulePath :: HaskellModulePath @@ -324,18 +323,14 @@ newtype ExternalIdentifierInfo = ExternalIdentifierInfo } 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 + compare (ExternalIdentifierInfo (IdentifierInfo { demangledOccName = d1, internalId = i1 })) (ExternalIdentifierInfo (IdentifierInfo { demangledOccName = d2, internalId = i2 })) + = case compare (T.length d1) (T.length d2) of + GT -> GT + LT -> LT + EQ -> case compare d1 d2 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)) + EQ -> compare i1 i2 data ExpressionInfo = ExpressionInfo { description :: T.Text @@ -688,39 +683,38 @@ lineToHtml lineNumber tokens = Html.tr $ do 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 + 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 (IdentifierOccurrence {..}) -> + addPositionAttrs + $ Html.span + Html.! Attr.class_ "identifier" + Html.! Attr.id + ( Html.textValue + . maybe "" getInternalId + $ internalIdFromRenamedSource + ) Html.! Html.dataAttribute - "start" - (Html.textValue $ T.pack . show $ start) + "occurrence" + ( Html.textValue + $ occurrenceLocationToText lineNumber start end + ) 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 + "identifier" + (Html.textValue $ maybe "" getInternalId $ internalId + ) + $ Html.toHtml content + Nothing -> addPositionAttrs . Html.span . Html.toHtml $ content ) tokens |