aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--app/Indexer.hs1
-rw-r--r--app/Server.hs144
-rw-r--r--app/Store.hs1
-rw-r--r--hcel.cabal1
-rw-r--r--src/HaskellCodeExplorer/AST/TypecheckedSource.hs1
-rw-r--r--src/HaskellCodeExplorer/PackageInfo.hs16
-rw-r--r--src/HaskellCodeExplorer/Types.hs80
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,
diff --git a/hcel.cabal b/hcel.cabal
index 73708f4..99fde6d 100644
--- a/hcel.cabal
+++ b/hcel.cabal
@@ -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