haskell/haskell-language-server
1
1
Fork 0
mirror of https://github.com/haskell/haskell-language-server.git synced 2024-09-11 16:56:14 +03:00
Code Issues Projects Releases Wiki Activity

Add pre-commit hook for cleaning up mixed-line endings (#2679)

Browse Source 
* Update pre-commit hook to include changing line endings

* Fix non-lf lines

* Check pre-commit excludes files

* Revert "Check pre-commit excludes files"

This reverts commit 7b9670f863.

* Actually add the exclude to contributing docs

* Fix merge failure with previous patch

* Inadvertently overwrote merge

* Add LF option for stylish-haskell and pre-commit file

Co-authored-by: Anton Latukha <anton.latukha@gmail.com>
Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
This commit is contained in:
Nick Suchecki 2022-02-04 09:50:18 -05:00 committed by GitHub
parent 9faa179017
commit 411db02883
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
25 changed files with 3232 additions and 3189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -32,7 +32,7 @@ test/testdata/**/hie.yaml
.shake/ .shake/
# pre-commit-hook.nix # pre-commit-hook.nix
.pre-commit-config.yaml #.pre-commit-config.yaml
# direnv # direnv
/.direnv/ /.direnv/

32
.pre-commit-config.yaml Normal file
View File

@ -0,0 +1,32 @@
{
"repos": [
{
"hooks": [
{
"entry": "stylish-haskell --inplace",
"exclude": "(^Setup.hs$|test/testdata/.*$|test/data/.*$|test/manual/lhs/.*$|^hie-compat/.*$|^plugins/hls-tactics-plugin/.*$|^ghcide/src/Development/IDE/GHC/Compat.hs$|^ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs$|^ghcide/src/Development/IDE/GHC/Compat/Core.hs$|^ghcide/src/Development/IDE/Spans/Pragmas.hs$|^ghcide/src/Development/IDE/LSP/Outline.hs$|^plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs$|^ghcide/test/exe/Main.hs$|ghcide/src/Development/IDE/Core/Rules.hs|^hls-test-utils/src/Test/Hls/Util.hs$)",
"files": "\\.l?hs$",
"id": "stylish-haskell",
"language": "system",
"name": "stylish-haskell",
"pass_filenames": true,
"types": [
"file"
]
}
],
"repo": "local"
},
{
"repo": "https://github.com/pre-commit/pre-commit-hooks",
"rev": "v4.1.0",
"hooks": [
{
"id": "mixed-line-ending",
"args": ["--fix", "lf"],
"exclude": "test/testdata/.*CRLF*.hs$"
}
]
}
]
}

2
.stylish-haskell.yaml
View File

@ -53,7 +53,7 @@ steps:
columns: 80 columns: 80
newline: native newline: lf
language_extensions: language_extensions:
- BangPatterns - BangPatterns

11
docs/contributing/contributing.md
View File

@ -199,6 +199,17 @@ If you don't want to use [nix](https://nixos.org/guides/install-nix.html), you c
} }
], ],
"repo": "local" "repo": "local"
},
{
"repo": "https://github.com/pre-commit/pre-commit-hooks",
"rev": "v4.1.0",
"hooks": [
{
"id": "mixed-line-ending",
"args": ["--fix", "lf"],
"exclude": "test/testdata/.*CRLF*.hs$"
}
]
} }
] ]
} }

324
ghcide/src/Development/IDE/Core/UseStale.hs
View File

@ -1,162 +1,162 @@
{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
module Development.IDE.Core.UseStale module Development.IDE.Core.UseStale
( Age(..) ( Age(..)
, Tracked , Tracked
, unTrack , unTrack
, PositionMap , PositionMap
, TrackedStale (..) , TrackedStale (..)
, untrackedStaleValue , untrackedStaleValue
, unsafeMkStale , unsafeMkStale
, unsafeMkCurrent , unsafeMkCurrent
, unsafeCopyAge , unsafeCopyAge
, MapAge (..) , MapAge (..)
, dualPositionMap , dualPositionMap
, useWithStale , useWithStale
, useWithStale_ , useWithStale_
) where ) where
import Control.Arrow import Control.Arrow
import Control.Category (Category) import Control.Category (Category)
import qualified Control.Category as C import qualified Control.Category as C
import Control.DeepSeq (NFData) import Control.DeepSeq (NFData)
import Data.Aeson import Data.Aeson
import Data.Coerce (coerce) import Data.Coerce (coerce)
import Data.Functor ((<&>)) import Data.Functor ((<&>))
import Data.Functor.Identity (Identity (Identity)) import Data.Functor.Identity (Identity (Identity))
import Data.Kind (Type) import Data.Kind (Type)
import Data.String (fromString) import Data.String (fromString)
import Development.IDE (Action, IdeRule, import Development.IDE (Action, IdeRule,
NormalizedFilePath, NormalizedFilePath,
Range, Range,
rangeToRealSrcSpan, rangeToRealSrcSpan,
realSrcSpanToRange) realSrcSpanToRange)
import qualified Development.IDE.Core.PositionMapping as P import qualified Development.IDE.Core.PositionMapping as P
import qualified Development.IDE.Core.Shake as IDE import qualified Development.IDE.Core.Shake as IDE
import Development.IDE.GHC.Compat (RealSrcSpan, srcSpanFile) import Development.IDE.GHC.Compat (RealSrcSpan, srcSpanFile)
import Development.IDE.GHC.Compat.Util (unpackFS) import Development.IDE.GHC.Compat.Util (unpackFS)
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | A data kind for 'Tracked'. -- | A data kind for 'Tracked'.
data Age = Current | Stale Type data Age = Current | Stale Type
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | Some value, tagged with its age. All 'Current' ages are considered to be -- | Some value, tagged with its age. All 'Current' ages are considered to be
-- the same thing, but 'Stale' values are protected by an untouchable variable -- the same thing, but 'Stale' values are protected by an untouchable variable
-- to ensure they can't be unified. -- to ensure they can't be unified.
newtype Tracked (age :: Age) a = UnsafeTracked newtype Tracked (age :: Age) a = UnsafeTracked
{ unTrack :: a { unTrack :: a
} }
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON, NFData) deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON, NFData)
deriving (Applicative, Monad) via Identity deriving (Applicative, Monad) via Identity
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | Like 'P.PositionMapping', but with annotated ages for how 'Tracked' values -- | Like 'P.PositionMapping', but with annotated ages for how 'Tracked' values
-- change. Use the 'Category' instance to compose 'PositionMapping's in order -- change. Use the 'Category' instance to compose 'PositionMapping's in order
-- to transform between values of different stale ages. -- to transform between values of different stale ages.
newtype PositionMap (from :: Age) (to :: Age) = PositionMap newtype PositionMap (from :: Age) (to :: Age) = PositionMap
{ _getPositionMapping :: P.PositionMapping { _getPositionMapping :: P.PositionMapping
} }
instance Category PositionMap where instance Category PositionMap where
id = coerce P.zeroMapping id = coerce P.zeroMapping
(.) = coerce P.composeDelta (.) = coerce P.composeDelta
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | Get a 'PositionMap' that runs in the opposite direction. -- | Get a 'PositionMap' that runs in the opposite direction.
dualPositionMap :: PositionMap from to -> PositionMap to from dualPositionMap :: PositionMap from to -> PositionMap to from
dualPositionMap (PositionMap (P.PositionMapping (P.PositionDelta from to))) = dualPositionMap (PositionMap (P.PositionMapping (P.PositionDelta from to))) =
PositionMap $ P.PositionMapping $ P.PositionDelta to from PositionMap $ P.PositionMapping $ P.PositionDelta to from
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | A pair containing a @'Tracked' 'Stale'@ value, as well as -- | A pair containing a @'Tracked' 'Stale'@ value, as well as
-- a 'PositionMapping' that will fast-forward values to the current age. -- a 'PositionMapping' that will fast-forward values to the current age.
data TrackedStale a where data TrackedStale a where
TrackedStale TrackedStale
:: Tracked (Stale s) a :: Tracked (Stale s) a
-> PositionMap (Stale s) Current -> PositionMap (Stale s) Current
-> TrackedStale a -> TrackedStale a
instance Functor TrackedStale where instance Functor TrackedStale where
fmap f (TrackedStale t pm) = TrackedStale (fmap f t) pm fmap f (TrackedStale t pm) = TrackedStale (fmap f t) pm
untrackedStaleValue :: TrackedStale a -> a untrackedStaleValue :: TrackedStale a -> a
untrackedStaleValue (TrackedStale ta _) = coerce ta untrackedStaleValue (TrackedStale ta _) = coerce ta
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | A class for which 'Tracked' values can be run across a 'PositionMapping' -- | A class for which 'Tracked' values can be run across a 'PositionMapping'
-- to change their ages. -- to change their ages.
class MapAge a where class MapAge a where
{-# MINIMAL mapAgeFrom | mapAgeTo #-} {-# MINIMAL mapAgeFrom | mapAgeTo #-}
mapAgeFrom :: PositionMap from to -> Tracked to a -> Maybe (Tracked from a) mapAgeFrom :: PositionMap from to -> Tracked to a -> Maybe (Tracked from a)
mapAgeFrom = mapAgeTo . dualPositionMap mapAgeFrom = mapAgeTo . dualPositionMap
mapAgeTo :: PositionMap from to -> Tracked from a -> Maybe (Tracked to a) mapAgeTo :: PositionMap from to -> Tracked from a -> Maybe (Tracked to a)
mapAgeTo = mapAgeFrom . dualPositionMap mapAgeTo = mapAgeFrom . dualPositionMap
instance MapAge Range where instance MapAge Range where
mapAgeFrom = coerce P.fromCurrentRange mapAgeFrom = coerce P.fromCurrentRange
mapAgeTo = coerce P.toCurrentRange mapAgeTo = coerce P.toCurrentRange
instance MapAge RealSrcSpan where instance MapAge RealSrcSpan where
mapAgeFrom = mapAgeFrom =
invMapAge (\fs -> rangeToRealSrcSpan (fromString $ unpackFS fs)) invMapAge (\fs -> rangeToRealSrcSpan (fromString $ unpackFS fs))
(srcSpanFile &&& realSrcSpanToRange) (srcSpanFile &&& realSrcSpanToRange)
. mapAgeFrom . mapAgeFrom
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | Helper function for deriving 'MapAge' for values in terms of other -- | Helper function for deriving 'MapAge' for values in terms of other
-- instances. -- instances.
invMapAge invMapAge
:: (c -> a -> b) :: (c -> a -> b)
-> (b -> (c, a)) -> (b -> (c, a))
-> (Tracked from a -> Maybe (Tracked to a)) -> (Tracked from a -> Maybe (Tracked to a))
-> Tracked from b -> Tracked from b
-> Maybe (Tracked to b) -> Maybe (Tracked to b)
invMapAge to from f t = invMapAge to from f t =
let (c, t') = unTrack $ fmap from t let (c, t') = unTrack $ fmap from t
in fmap (fmap $ to c) $ f $ UnsafeTracked t' in fmap (fmap $ to c) $ f $ UnsafeTracked t'
unsafeMkCurrent :: age -> Tracked 'Current age unsafeMkCurrent :: age -> Tracked 'Current age
unsafeMkCurrent = coerce unsafeMkCurrent = coerce
unsafeMkStale :: age -> Tracked (Stale s) age unsafeMkStale :: age -> Tracked (Stale s) age
unsafeMkStale = coerce unsafeMkStale = coerce
unsafeCopyAge :: Tracked age a -> b -> Tracked age b unsafeCopyAge :: Tracked age a -> b -> Tracked age b
unsafeCopyAge _ = coerce unsafeCopyAge _ = coerce
-- | Request a Rule result, it not available return the last computed result, if any, which may be stale -- | Request a Rule result, it not available return the last computed result, if any, which may be stale
useWithStale :: IdeRule k v useWithStale :: IdeRule k v
=> k -> NormalizedFilePath -> Action (Maybe (TrackedStale v)) => k -> NormalizedFilePath -> Action (Maybe (TrackedStale v))
useWithStale key file = do useWithStale key file = do
x <- IDE.useWithStale key file x <- IDE.useWithStale key file
pure $ x <&> \(v, pm) -> pure $ x <&> \(v, pm) ->
TrackedStale (coerce v) (coerce pm) TrackedStale (coerce v) (coerce pm)
-- | Request a Rule result, it not available return the last computed result which may be stale. -- | Request a Rule result, it not available return the last computed result which may be stale.
-- Errors out if none available. -- Errors out if none available.
useWithStale_ :: IdeRule k v useWithStale_ :: IdeRule k v
=> k -> NormalizedFilePath -> Action (TrackedStale v) => k -> NormalizedFilePath -> Action (TrackedStale v)
useWithStale_ key file = do useWithStale_ key file = do
(v, pm) <- IDE.useWithStale_ key file (v, pm) <- IDE.useWithStale_ key file
pure $ TrackedStale (coerce v) (coerce pm) pure $ TrackedStale (coerce v) (coerce pm)

126
ghcide/src/Development/IDE/GHC/CPP.hs
View File

@ -1,63 +1,63 @@
-- Copyright (c) 2019 The DAML Authors. All rights reserved. -- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0 -- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE NondecreasingIndentation #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- --
-- GHC Driver -- GHC Driver
-- --
-- (c) The University of Glasgow 2005 -- (c) The University of Glasgow 2005
-- --
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module Development.IDE.GHC.CPP(doCpp, addOptP) module Development.IDE.GHC.CPP(doCpp, addOptP)
where where
import Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat as Compat
import GHC import GHC
#if !MIN_VERSION_ghc(8,10,0) #if !MIN_VERSION_ghc(8,10,0)
import qualified Development.IDE.GHC.Compat.CPP as CPP import qualified Development.IDE.GHC.Compat.CPP as CPP
#else #else
import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Compat.Util
#endif #endif
#if MIN_VERSION_ghc(9,0,0) #if MIN_VERSION_ghc(9,0,0)
import qualified GHC.Driver.Pipeline as Pipeline import qualified GHC.Driver.Pipeline as Pipeline
import GHC.Settings import GHC.Settings
#else #else
#if MIN_VERSION_ghc (8,10,0) #if MIN_VERSION_ghc (8,10,0)
import qualified DriverPipeline as Pipeline import qualified DriverPipeline as Pipeline
import ToolSettings import ToolSettings
#else #else
import DynFlags import DynFlags
#endif #endif
#endif #endif
addOptP :: String -> DynFlags -> DynFlags addOptP :: String -> DynFlags -> DynFlags
#if MIN_VERSION_ghc (8,10,0) #if MIN_VERSION_ghc (8,10,0)
addOptP f = alterToolSettings $ \s -> s addOptP f = alterToolSettings $ \s -> s
{ toolSettings_opt_P = f : toolSettings_opt_P s { toolSettings_opt_P = f : toolSettings_opt_P s
, toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)
} }
where where
fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss
alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }
#else #else
addOptP opt = onSettings (onOptP (opt:)) addOptP opt = onSettings (onOptP (opt:))
where where
onSettings f x = x{settings = f $ settings x} onSettings f x = x{settings = f $ settings x}
onOptP f x = x{sOpt_P = f $ sOpt_P x} onOptP f x = x{sOpt_P = f $ sOpt_P x}
#endif #endif
doCpp :: HscEnv -> Bool -> FilePath -> FilePath -> IO () doCpp :: HscEnv -> Bool -> FilePath -> FilePath -> IO ()
doCpp env raw input_fn output_fn = doCpp env raw input_fn output_fn =
#if MIN_VERSION_ghc (9,2,0) #if MIN_VERSION_ghc (9,2,0)
Pipeline.doCpp (hsc_logger env) (hsc_tmpfs env) (hsc_dflags env) (hsc_unit_env env) raw input_fn output_fn Pipeline.doCpp (hsc_logger env) (hsc_tmpfs env) (hsc_dflags env) (hsc_unit_env env) raw input_fn output_fn
#elif MIN_VERSION_ghc (8,10,0) #elif MIN_VERSION_ghc (8,10,0)
Pipeline.doCpp (hsc_dflags env) raw input_fn output_fn Pipeline.doCpp (hsc_dflags env) raw input_fn output_fn
#else #else
CPP.doCpp (hsc_dflags env) raw input_fn output_fn CPP.doCpp (hsc_dflags env) raw input_fn output_fn
#endif #endif

408
ghcide/src/Development/IDE/GHC/Compat/CPP.hs
View File

@ -1,204 +1,204 @@
-- Copyright (c) 2019 The DAML Authors. All rights reserved. -- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0 -- SPDX-License-Identifier: Apache-2.0
-- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019 -- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019
-- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944. -- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944.
-- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed. -- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed.
{- HLINT ignore -} -- since copied from upstream {- HLINT ignore -} -- since copied from upstream
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-- | Re-export 'doCpp' for GHC < 8.10. -- | Re-export 'doCpp' for GHC < 8.10.
-- --
-- Later versions export what we need. -- Later versions export what we need.
module Development.IDE.GHC.Compat.CPP ( module Development.IDE.GHC.Compat.CPP (
doCpp doCpp
) where ) where
import FileCleanup import FileCleanup
import Packages import Packages
import Panic import Panic
import SysTools import SysTools
#if MIN_VERSION_ghc(8,8,2) #if MIN_VERSION_ghc(8,8,2)
import LlvmCodeGen (llvmVersionList) import LlvmCodeGen (llvmVersionList)
#elif MIN_VERSION_ghc(8,8,0) #elif MIN_VERSION_ghc(8,8,0)
import LlvmCodeGen (LlvmVersion (..)) import LlvmCodeGen (LlvmVersion (..))
#endif #endif
import Control.Monad import Control.Monad
import Data.List (intercalate) import Data.List (intercalate)
import Data.Maybe import Data.Maybe
import Data.Version import Data.Version
import DynFlags import DynFlags
import Module (rtsUnitId, toInstalledUnitId) import Module (rtsUnitId, toInstalledUnitId)
import System.Directory import System.Directory
import System.FilePath import System.FilePath
import System.Info import System.Info
import Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat as Compat
doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
doCpp dflags raw input_fn output_fn = do doCpp dflags raw input_fn output_fn = do
let hscpp_opts = picPOpts dflags let hscpp_opts = picPOpts dflags
let cmdline_include_paths = includePaths dflags let cmdline_include_paths = includePaths dflags
pkg_include_dirs <- getPackageIncludePath dflags [] pkg_include_dirs <- getPackageIncludePath dflags []
let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
(includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
(includePathsQuote cmdline_include_paths) (includePathsQuote cmdline_include_paths)
let include_paths = include_paths_quote ++ include_paths_global let include_paths = include_paths_quote ++ include_paths_global
let verbFlags = getVerbFlags dflags let verbFlags = getVerbFlags dflags
let cpp_prog args | raw = SysTools.runCpp dflags args let cpp_prog args | raw = SysTools.runCpp dflags args
#if MIN_VERSION_ghc(8,10,0) #if MIN_VERSION_ghc(8,10,0)
| otherwise = SysTools.runCc Nothing | otherwise = SysTools.runCc Nothing
#else #else
| otherwise = SysTools.runCc | otherwise = SysTools.runCc
#endif #endif
dflags (SysTools.Option "-E" : args) dflags (SysTools.Option "-E" : args)
let target_defs = let target_defs =
-- NEIL: Patched to use System.Info instead of constants from CPP -- NEIL: Patched to use System.Info instead of constants from CPP
[ "-D" ++ os ++ "_BUILD_OS", [ "-D" ++ os ++ "_BUILD_OS",
"-D" ++ arch ++ "_BUILD_ARCH", "-D" ++ arch ++ "_BUILD_ARCH",
"-D" ++ os ++ "_HOST_OS", "-D" ++ os ++ "_HOST_OS",
"-D" ++ arch ++ "_HOST_ARCH" ] "-D" ++ arch ++ "_HOST_ARCH" ]
-- remember, in code we *compile*, the HOST is the same our TARGET, -- remember, in code we *compile*, the HOST is the same our TARGET,
-- and BUILD is the same as our HOST. -- and BUILD is the same as our HOST.
let sse_defs = let sse_defs =
[ "-D__SSE__" | isSseEnabled dflags ] ++ [ "-D__SSE__" | isSseEnabled dflags ] ++
[ "-D__SSE2__" | isSse2Enabled dflags ] ++ [ "-D__SSE2__" | isSse2Enabled dflags ] ++
[ "-D__SSE4_2__" | isSse4_2Enabled dflags ] [ "-D__SSE4_2__" | isSse4_2Enabled dflags ]
let avx_defs = let avx_defs =
[ "-D__AVX__" | isAvxEnabled dflags ] ++ [ "-D__AVX__" | isAvxEnabled dflags ] ++
[ "-D__AVX2__" | isAvx2Enabled dflags ] ++ [ "-D__AVX2__" | isAvx2Enabled dflags ] ++
[ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
[ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
[ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++
[ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
backend_defs <- getBackendDefs dflags backend_defs <- getBackendDefs dflags
let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
-- Default CPP defines in Haskell source -- Default CPP defines in Haskell source
ghcVersionH <- getGhcVersionPathName dflags ghcVersionH <- getGhcVersionPathName dflags
let hsSourceCppOpts = [ "-include", ghcVersionH ] let hsSourceCppOpts = [ "-include", ghcVersionH ]
-- MIN_VERSION macros -- MIN_VERSION macros
let uids = explicitPackages (pkgState dflags) let uids = explicitPackages (pkgState dflags)
pkgs = catMaybes (map (lookupPackage dflags) uids) pkgs = catMaybes (map (lookupPackage dflags) uids)
mb_macro_include <- mb_macro_include <-
if not (null pkgs) && gopt Opt_VersionMacros dflags if not (null pkgs) && gopt Opt_VersionMacros dflags
then do macro_stub <- newTempName dflags TFL_CurrentModule "h" then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
writeFile macro_stub (generatePackageVersionMacros pkgs) writeFile macro_stub (generatePackageVersionMacros pkgs)
-- Include version macros for every *exposed* package. -- Include version macros for every *exposed* package.
-- Without -hide-all-packages and with a package database -- Without -hide-all-packages and with a package database
-- size of 1000 packages, it takes cpp an estimated 2 -- size of 1000 packages, it takes cpp an estimated 2
-- milliseconds to process this file. See #10970 -- milliseconds to process this file. See #10970
-- comment 8. -- comment 8.
return [SysTools.FileOption "-include" macro_stub] return [SysTools.FileOption "-include" macro_stub]
else return [] else return []
cpp_prog ( map SysTools.Option verbFlags cpp_prog ( map SysTools.Option verbFlags
++ map SysTools.Option include_paths ++ map SysTools.Option include_paths
++ map SysTools.Option hsSourceCppOpts ++ map SysTools.Option hsSourceCppOpts
++ map SysTools.Option target_defs ++ map SysTools.Option target_defs
++ map SysTools.Option backend_defs ++ map SysTools.Option backend_defs
++ map SysTools.Option th_defs ++ map SysTools.Option th_defs
++ map SysTools.Option hscpp_opts ++ map SysTools.Option hscpp_opts
++ map SysTools.Option sse_defs ++ map SysTools.Option sse_defs
++ map SysTools.Option avx_defs ++ map SysTools.Option avx_defs
++ mb_macro_include ++ mb_macro_include
-- Set the language mode to assembler-with-cpp when preprocessing. This -- Set the language mode to assembler-with-cpp when preprocessing. This
-- alleviates some of the C99 macro rules relating to whitespace and the hash -- alleviates some of the C99 macro rules relating to whitespace and the hash
-- operator, which we tend to abuse. Clang in particular is not very happy -- operator, which we tend to abuse. Clang in particular is not very happy
-- about this. -- about this.
++ [ SysTools.Option "-x" ++ [ SysTools.Option "-x"
, SysTools.Option "assembler-with-cpp" , SysTools.Option "assembler-with-cpp"
, SysTools.Option input_fn , SysTools.Option input_fn
-- We hackily use Option instead of FileOption here, so that the file -- We hackily use Option instead of FileOption here, so that the file
-- name is not back-slashed on Windows. cpp is capable of -- name is not back-slashed on Windows. cpp is capable of
-- dealing with / in filenames, so it works fine. Furthermore -- dealing with / in filenames, so it works fine. Furthermore
-- if we put in backslashes, cpp outputs #line directives -- if we put in backslashes, cpp outputs #line directives
-- with *double* backslashes. And that in turn means that -- with *double* backslashes. And that in turn means that
-- our error messages get double backslashes in them. -- our error messages get double backslashes in them.
-- In due course we should arrange that the lexer deals -- In due course we should arrange that the lexer deals
-- with these \\ escapes properly. -- with these \\ escapes properly.
, SysTools.Option "-o" , SysTools.Option "-o"
, SysTools.FileOption "" output_fn , SysTools.FileOption "" output_fn
]) ])
getBackendDefs :: DynFlags -> IO [String] getBackendDefs :: DynFlags -> IO [String]
getBackendDefs dflags | hscTarget dflags == HscLlvm = do getBackendDefs dflags | hscTarget dflags == HscLlvm = do
llvmVer <- figureLlvmVersion dflags llvmVer <- figureLlvmVersion dflags
return $ case llvmVer of return $ case llvmVer of
#if MIN_VERSION_ghc(8,8,2) #if MIN_VERSION_ghc(8,8,2)
Just v Just v
| [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ] | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ]
| m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ] | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ]
#elif MIN_VERSION_ghc(8,8,0) #elif MIN_VERSION_ghc(8,8,0)
Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ] Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]
Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
#else #else
Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ] Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]
#endif #endif
_ -> [] _ -> []
where where
format (major, minor) format (major, minor)
| minor >= 100 = error "getBackendDefs: Unsupported minor version" | minor >= 100 = error "getBackendDefs: Unsupported minor version"
| otherwise = show $ (100 * major + minor :: Int) -- Contract is Int | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int
getBackendDefs _ = getBackendDefs _ =
return [] return []
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
-- Macros (cribbed from Cabal) -- Macros (cribbed from Cabal)
generatePackageVersionMacros :: [Compat.UnitInfo] -> String generatePackageVersionMacros :: [Compat.UnitInfo] -> String
generatePackageVersionMacros pkgs = concat generatePackageVersionMacros pkgs = concat
-- Do not add any C-style comments. See #3389. -- Do not add any C-style comments. See #3389.
[ generateMacros "" pkgname version [ generateMacros "" pkgname version
| pkg <- pkgs | pkg <- pkgs
, let version = packageVersion pkg , let version = packageVersion pkg
pkgname = map fixchar (packageNameString pkg) pkgname = map fixchar (packageNameString pkg)
] ]
fixchar :: Char -> Char fixchar :: Char -> Char
fixchar '-' = '_' fixchar '-' = '_'
fixchar c = c fixchar c = c
generateMacros :: String -> String -> Version -> String generateMacros :: String -> String -> Version -> String
generateMacros prefix name version = generateMacros prefix name version =
concat concat
["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
," (major1) < ",major1," || \\\n" ," (major1) < ",major1," || \\\n"
," (major1) == ",major1," && (major2) < ",major2," || \\\n" ," (major1) == ",major1," && (major2) < ",major2," || \\\n"
," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
,"\n\n" ,"\n\n"
] ]
where where
(major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
-- | Find out path to @ghcversion.h@ file -- | Find out path to @ghcversion.h@ file
getGhcVersionPathName :: DynFlags -> IO FilePath getGhcVersionPathName :: DynFlags -> IO FilePath
getGhcVersionPathName dflags = do getGhcVersionPathName dflags = do
candidates <- case ghcVersionFile dflags of candidates <- case ghcVersionFile dflags of
Just path -> return [path] Just path -> return [path]
Nothing -> (map (</> "ghcversion.h")) <$> Nothing -> (map (</> "ghcversion.h")) <$>
(getPackageIncludePath dflags [toInstalledUnitId rtsUnit]) (getPackageIncludePath dflags [toInstalledUnitId rtsUnit])
found <- filterM doesFileExist candidates found <- filterM doesFileExist candidates
case found of case found of
[] -> throwGhcExceptionIO (InstallationError [] -> throwGhcExceptionIO (InstallationError
("ghcversion.h missing; tried: " ("ghcversion.h missing; tried: "
++ intercalate ", " candidates)) ++ intercalate ", " candidates))
(x:_) -> return x (x:_) -> return x
rtsUnit :: UnitId rtsUnit :: UnitId
rtsUnit = Module.rtsUnitId rtsUnit = Module.rtsUnitId

106
ghcide/src/Development/IDE/Main/HeapStats.hs
View File

@ -1,53 +1,53 @@
{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE NumericUnderscores #-}
-- | Logging utilities for reporting heap statistics -- | Logging utilities for reporting heap statistics
module Development.IDE.Main.HeapStats ( withHeapStats ) where module Development.IDE.Main.HeapStats ( withHeapStats ) where
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Monad import Control.Monad
import qualified Data.Text as T import qualified Data.Text as T
import Data.Word import Data.Word
import Development.IDE.Types.Logger (Logger, logInfo) import Development.IDE.Types.Logger (Logger, logInfo)
import GHC.Stats import GHC.Stats
import Text.Printf (printf) import Text.Printf (printf)
-- | Interval at which to report the latest heap statistics. -- | Interval at which to report the latest heap statistics.
heapStatsInterval :: Int heapStatsInterval :: Int
heapStatsInterval = 60_000_000 -- 60s heapStatsInterval = 60_000_000 -- 60s
-- | Report the live bytes and heap size at the last major collection. -- | Report the live bytes and heap size at the last major collection.
logHeapStats :: Logger -> IO () logHeapStats :: Logger -> IO ()
logHeapStats l = do logHeapStats l = do
stats <- getRTSStats stats <- getRTSStats
-- live_bytes is the total amount of live memory in a program -- live_bytes is the total amount of live memory in a program
-- (corresponding to the amount on a heap profile) -- (corresponding to the amount on a heap profile)
let live_bytes = gcdetails_live_bytes (gc stats) let live_bytes = gcdetails_live_bytes (gc stats)
-- heap_size is the total amount of memory the RTS is using -- heap_size is the total amount of memory the RTS is using
-- this corresponds closer to OS memory usage -- this corresponds closer to OS memory usage
heap_size = gcdetails_mem_in_use_bytes (gc stats) heap_size = gcdetails_mem_in_use_bytes (gc stats)
format :: Word64 -> T.Text format :: Word64 -> T.Text
format m = T.pack (printf "%.2fMB" (fromIntegral @Word64 @Double m / 1e6)) format m = T.pack (printf "%.2fMB" (fromIntegral @Word64 @Double m / 1e6))
message = "Live bytes: " <> format live_bytes <> " " <> message = "Live bytes: " <> format live_bytes <> " " <>
"Heap size: " <> format heap_size "Heap size: " <> format heap_size
logInfo l message logInfo l message
-- | An action which logs heap statistics at the 'heapStatsInterval' -- | An action which logs heap statistics at the 'heapStatsInterval'
heapStatsThread :: Logger -> IO r heapStatsThread :: Logger -> IO r
heapStatsThread l = forever $ do heapStatsThread l = forever $ do
threadDelay heapStatsInterval threadDelay heapStatsInterval
logHeapStats l logHeapStats l
-- | A helper function which lauches the 'heapStatsThread' and kills it -- | A helper function which lauches the 'heapStatsThread' and kills it
-- appropiately when the inner action finishes. It also checks to see -- appropiately when the inner action finishes. It also checks to see
-- if `-T` is enabled. -- if `-T` is enabled.
withHeapStats :: Logger -> IO r -> IO r withHeapStats :: Logger -> IO r -> IO r
withHeapStats l k = do withHeapStats l k = do
enabled <- getRTSStatsEnabled enabled <- getRTSStatsEnabled
if enabled if enabled
then do then do
logInfo l ("Logging heap statistics every " logInfo l ("Logging heap statistics every "
<> T.pack (printf "%.2fs" (fromIntegral @Int @Double heapStatsInterval / 1e6))) <> T.pack (printf "%.2fs" (fromIntegral @Int @Double heapStatsInterval / 1e6)))
withAsync (heapStatsThread l) (const k) withAsync (heapStatsThread l) (const k)
else do else do
logInfo l "Heap statistics are not enabled (RTS option -T is needed)" logInfo l "Heap statistics are not enabled (RTS option -T is needed)"
k k

2
ghcide/src/Development/IDE/Plugin/Completions/Logic.hs
View File

@ -31,7 +31,7 @@ import Data.Function (on)
import Data.Functor import Data.Functor
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
import Data.Monoid (First(..)) import Data.Monoid (First (..))
import Data.Ord (Down (Down)) import Data.Ord (Down (Down))
import qualified Data.Set as Set import qualified Data.Set as Set
import Development.IDE.Core.Compile import Development.IDE.Core.Compile

448
ghcide/src/Development/IDE/Spans/Documentation.hs
View File

@ -1,224 +1,224 @@
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
-- Copyright (c) 2019 The DAML Authors. All rights reserved. -- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0 -- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Development.IDE.Spans.Documentation ( module Development.IDE.Spans.Documentation (
getDocumentation getDocumentation
, getDocumentationTryGhc , getDocumentationTryGhc
, getDocumentationsTryGhc , getDocumentationsTryGhc
, DocMap , DocMap
, mkDocMap , mkDocMap
) where ) where
import Control.Monad import Control.Monad
import Control.Monad.Extra (findM) import Control.Monad.Extra (findM)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Data.Either import Data.Either
import Data.Foldable import Data.Foldable
import Data.List.Extra import Data.List.Extra
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe import Data.Maybe
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Text as T import qualified Data.Text as T
import Development.IDE.Core.Compile import Development.IDE.Core.Compile
import Development.IDE.Core.RuleTypes import Development.IDE.Core.RuleTypes
import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat
import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Compat.Util
import Development.IDE.GHC.Error import Development.IDE.GHC.Error
import Development.IDE.Spans.Common import Development.IDE.Spans.Common
import System.Directory import System.Directory
import System.FilePath import System.FilePath
import Language.LSP.Types (filePathToUri, getUri) import Language.LSP.Types (filePathToUri, getUri)
mkDocMap mkDocMap
:: HscEnv :: HscEnv
-> RefMap a -> RefMap a
-> TcGblEnv -> TcGblEnv
-> IO DocAndKindMap -> IO DocAndKindMap
mkDocMap env rm this_mod = mkDocMap env rm this_mod =
do do
#if MIN_VERSION_ghc(9,2,0) #if MIN_VERSION_ghc(9,2,0)
(_ , DeclDocMap this_docs, _) <- extractDocs this_mod (_ , DeclDocMap this_docs, _) <- extractDocs this_mod
#else #else
let (_ , DeclDocMap this_docs, _) = extractDocs this_mod let (_ , DeclDocMap this_docs, _) = extractDocs this_mod
#endif #endif
d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names
k <- foldrM getType (tcg_type_env this_mod) names k <- foldrM getType (tcg_type_env this_mod) names
pure $ DKMap d k pure $ DKMap d k
where where
getDocs n map getDocs n map
| maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist
| otherwise = do | otherwise = do
doc <- getDocumentationTryGhc env mod n doc <- getDocumentationTryGhc env mod n
pure $ extendNameEnv map n doc pure $ extendNameEnv map n doc
getType n map getType n map
| isTcOcc $ occName n = do | isTcOcc $ occName n = do
kind <- lookupKind env mod n kind <- lookupKind env mod n
pure $ maybe map (extendNameEnv map n) kind pure $ maybe map (extendNameEnv map n) kind
| otherwise = pure map | otherwise = pure map
names = rights $ S.toList idents names = rights $ S.toList idents
idents = M.keysSet rm idents = M.keysSet rm
mod = tcg_mod this_mod mod = tcg_mod this_mod
lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing) lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing)
lookupKind env mod = lookupKind env mod =
fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod
getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc
getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n] getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n]
getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc] getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc]
getDocumentationsTryGhc env mod names = do getDocumentationsTryGhc env mod names = do
res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names
case res of case res of
Left _ -> return [] Left _ -> return []
Right res -> zipWithM unwrap res names Right res -> zipWithM unwrap res names
where where
unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n
unwrap _ n = mkSpanDocText n unwrap _ n = mkSpanDocText n
mkSpanDocText name = mkSpanDocText name =
SpanDocText [] <$> getUris name SpanDocText [] <$> getUris name
-- Get the uris to the documentation and source html pages if they exist -- Get the uris to the documentation and source html pages if they exist
getUris name = do getUris name = do
(docFu, srcFu) <- (docFu, srcFu) <-
case nameModule_maybe name of case nameModule_maybe name of
Just mod -> liftIO $ do Just mod -> liftIO $ do
doc <- toFileUriText $ lookupDocHtmlForModule env mod doc <- toFileUriText $ lookupDocHtmlForModule env mod
src <- toFileUriText $ lookupSrcHtmlForModule env mod src <- toFileUriText $ lookupSrcHtmlForModule env mod
return (doc, src) return (doc, src)
Nothing -> pure (Nothing, Nothing) Nothing -> pure (Nothing, Nothing)
let docUri = (<> "#" <> selector <> showNameWithoutUniques name) <$> docFu let docUri = (<> "#" <> selector <> showNameWithoutUniques name) <$> docFu
srcUri = (<> "#" <> showNameWithoutUniques name) <$> srcFu srcUri = (<> "#" <> showNameWithoutUniques name) <$> srcFu
selector selector
| isValName name = "v:" | isValName name = "v:"
| otherwise = "t:" | otherwise = "t:"
return $ SpanDocUris docUri srcUri return $ SpanDocUris docUri srcUri
toFileUriText = (fmap . fmap) (getUri . filePathToUri) toFileUriText = (fmap . fmap) (getUri . filePathToUri)
getDocumentation getDocumentation
:: HasSrcSpan name :: HasSrcSpan name
=> [ParsedModule] -- ^ All of the possible modules it could be defined in. => [ParsedModule] -- ^ All of the possible modules it could be defined in.
-> name -- ^ The name you want documentation for. -> name -- ^ The name you want documentation for.
-> [T.Text] -> [T.Text]
-- This finds any documentation between the name you want -- This finds any documentation between the name you want
-- documentation for and the one before it. This is only an -- documentation for and the one before it. This is only an
-- approximately correct algorithm and there are easily constructed -- approximately correct algorithm and there are easily constructed
-- cases where it will be wrong (if so then usually slightly but there -- cases where it will be wrong (if so then usually slightly but there
-- may be edge cases where it is very wrong). -- may be edge cases where it is very wrong).
-- TODO : Build a version of GHC exactprint to extract this information -- TODO : Build a version of GHC exactprint to extract this information
-- more accurately. -- more accurately.
-- TODO : Implement this for GHC 9.2 with in-tree annotations -- TODO : Implement this for GHC 9.2 with in-tree annotations
-- (alternatively, just remove it and rely soley on GHC's parsing) -- (alternatively, just remove it and rely soley on GHC's parsing)
getDocumentation sources targetName = fromMaybe [] $ do getDocumentation sources targetName = fromMaybe [] $ do
#if MIN_VERSION_ghc(9,2,0) #if MIN_VERSION_ghc(9,2,0)
Nothing Nothing
#else #else
-- Find the module the target is defined in. -- Find the module the target is defined in.
targetNameSpan <- realSpan $ getLoc targetName targetNameSpan <- realSpan $ getLoc targetName
tc <- tc <-
find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName) find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)
$ reverse sources -- TODO : Is reversing the list here really neccessary? $ reverse sources -- TODO : Is reversing the list here really neccessary?
-- Top level names bound by the module -- Top level names bound by the module
let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc
, L _ (ValD _ hsbind) <- hsmodDecls , L _ (ValD _ hsbind) <- hsmodDecls
, Just n <- [name_of_bind hsbind] , Just n <- [name_of_bind hsbind]
] ]
-- Sort the names' source spans. -- Sort the names' source spans.
let sortedSpans = sortedNameSpans bs let sortedSpans = sortedNameSpans bs
-- Now go ahead and extract the docs. -- Now go ahead and extract the docs.
let docs = ann tc let docs = ann tc
nameInd <- elemIndex targetNameSpan sortedSpans nameInd <- elemIndex targetNameSpan sortedSpans
let prevNameSpan = let prevNameSpan =
if nameInd >= 1 if nameInd >= 1
then sortedSpans !! (nameInd - 1) then sortedSpans !! (nameInd - 1)
else zeroSpan $ srcSpanFile targetNameSpan else zeroSpan $ srcSpanFile targetNameSpan
-- Annoyingly "-- |" documentation isn't annotated with a location, -- Annoyingly "-- |" documentation isn't annotated with a location,
-- so you have to pull it out from the elements. -- so you have to pull it out from the elements.
pure pure
$ docHeaders $ docHeaders
$ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan) $ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan)
$ fold $ fold
docs docs
where where
-- Get the name bound by a binding. We only concern ourselves with -- Get the name bound by a binding. We only concern ourselves with
-- @FunBind@ (which covers functions and variables). -- @FunBind@ (which covers functions and variables).
name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName) name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)
name_of_bind FunBind {fun_id} = Just fun_id name_of_bind FunBind {fun_id} = Just fun_id
name_of_bind _ = Nothing name_of_bind _ = Nothing
-- Get source spans from names, discard unhelpful spans, remove -- Get source spans from names, discard unhelpful spans, remove
-- duplicates and sort. -- duplicates and sort.
sortedNameSpans :: [Located RdrName] -> [RealSrcSpan] sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]
sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls) sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)
isBetween target before after = before <= target && target <= after isBetween target before after = before <= target && target <= after
#if MIN_VERSION_ghc(9,0,0) #if MIN_VERSION_ghc(9,0,0)
ann = apiAnnComments . pm_annotations ann = apiAnnComments . pm_annotations
#else #else
ann = fmap filterReal . snd . pm_annotations ann = fmap filterReal . snd . pm_annotations
filterReal :: [Located a] -> [RealLocated a] filterReal :: [Located a] -> [RealLocated a]
filterReal = mapMaybe (\(L l v) -> (`L`v) <$> realSpan l) filterReal = mapMaybe (\(L l v) -> (`L`v) <$> realSpan l)
#endif #endif
annotationFileName :: ParsedModule -> Maybe FastString annotationFileName :: ParsedModule -> Maybe FastString
annotationFileName = fmap srcSpanFile . listToMaybe . map getRealSrcSpan . fold . ann annotationFileName = fmap srcSpanFile . listToMaybe . map getRealSrcSpan . fold . ann
-- | Shows this part of the documentation -- | Shows this part of the documentation
docHeaders :: [RealLocated AnnotationComment] docHeaders :: [RealLocated AnnotationComment]
-> [T.Text] -> [T.Text]
docHeaders = mapMaybe (\(L _ x) -> wrk x) docHeaders = mapMaybe (\(L _ x) -> wrk x)
where where
wrk = \case wrk = \case
-- When `Opt_Haddock` is enabled. -- When `Opt_Haddock` is enabled.
AnnDocCommentNext s -> Just $ T.pack s AnnDocCommentNext s -> Just $ T.pack s
-- When `Opt_KeepRawTokenStream` enabled. -- When `Opt_KeepRawTokenStream` enabled.
AnnLineComment s -> if "-- |" `isPrefixOf` s AnnLineComment s -> if "-- |" `isPrefixOf` s
then Just $ T.pack s then Just $ T.pack s
else Nothing else Nothing
_ -> Nothing _ -> Nothing
#endif #endif
-- These are taken from haskell-ide-engine's Haddock plugin -- These are taken from haskell-ide-engine's Haddock plugin
-- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page. -- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page.
-- An example for a cabal installed module: -- An example for a cabal installed module:
-- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/Data-Vector-Primitive.html@ -- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/Data-Vector-Primitive.html@
lookupDocHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath) lookupDocHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath)
lookupDocHtmlForModule = lookupDocHtmlForModule =
lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> modDocName <.> "html") lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> modDocName <.> "html")
-- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page. -- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page.
-- An example for a cabal installed module: -- An example for a cabal installed module:
-- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/src/Data.Vector.Primitive.html@ -- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/src/Data.Vector.Primitive.html@
lookupSrcHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath) lookupSrcHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath)
lookupSrcHtmlForModule = lookupSrcHtmlForModule =
lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> "src" </> modDocName <.> "html") lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> "src" </> modDocName <.> "html")
lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> HscEnv -> Module -> IO (Maybe FilePath) lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> HscEnv -> Module -> IO (Maybe FilePath)
lookupHtmlForModule mkDocPath hscEnv m = do lookupHtmlForModule mkDocPath hscEnv m = do
-- try all directories -- try all directories
let mfs = fmap (concatMap go) (lookupHtmls hscEnv ui) let mfs = fmap (concatMap go) (lookupHtmls hscEnv ui)
html <- findM doesFileExist (concat . maybeToList $ mfs) html <- findM doesFileExist (concat . maybeToList $ mfs)
-- canonicalize located html to remove /../ indirection which can break some clients -- canonicalize located html to remove /../ indirection which can break some clients
-- (vscode on Windows at least) -- (vscode on Windows at least)
traverse canonicalizePath html traverse canonicalizePath html
where where
go pkgDocDir = map (mkDocPath pkgDocDir) mns go pkgDocDir = map (mkDocPath pkgDocDir) mns
ui = moduleUnit m ui = moduleUnit m
-- try to locate html file from most to least specific name e.g. -- try to locate html file from most to least specific name e.g.
-- first Language.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html -- first Language.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html
-- then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc. -- then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc.
mns = do mns = do
chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m
-- The file might use "." or "-" as separator -- The file might use "." or "-" as separator
map (`intercalate` chunks) [".", "-"] map (`intercalate` chunks) [".", "-"]
lookupHtmls :: HscEnv -> Unit -> Maybe [FilePath] lookupHtmls :: HscEnv -> Unit -> Maybe [FilePath]
lookupHtmls df ui = lookupHtmls df ui =
-- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path
-- and therefore doesn't expand $topdir on Windows -- and therefore doesn't expand $topdir on Windows
map takeDirectory . unitHaddockInterfaces <$> lookupUnit df ui map takeDirectory . unitHaddockInterfaces <$> lookupUnit df ui

280
ghcide/src/Development/IDE/Spans/LocalBindings.hs
View File

@ -1,140 +1,140 @@
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
module Development.IDE.Spans.LocalBindings module Development.IDE.Spans.LocalBindings
( Bindings ( Bindings
, getLocalScope , getLocalScope
, getFuzzyScope , getFuzzyScope
, getDefiningBindings , getDefiningBindings
, getFuzzyDefiningBindings , getFuzzyDefiningBindings
, bindings , bindings
) where ) where
import Control.DeepSeq import Control.DeepSeq
import Control.Monad import Control.Monad
import Data.Bifunctor import Data.Bifunctor
import Data.IntervalMap.FingerTree (Interval (..), IntervalMap) import Data.IntervalMap.FingerTree (Interval (..), IntervalMap)
import qualified Data.IntervalMap.FingerTree as IM import qualified Data.IntervalMap.FingerTree as IM
import qualified Data.List as L import qualified Data.List as L
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Set as S import qualified Data.Set as S
import Development.IDE.GHC.Compat (Name, NameEnv, RealSrcSpan, import Development.IDE.GHC.Compat (Name, NameEnv, RealSrcSpan,
RefMap, Scope (..), Type, RefMap, Scope (..), Type,
getBindSiteFromContext, getBindSiteFromContext,
getScopeFromContext, identInfo, getScopeFromContext, identInfo,
identType, isSystemName, identType, isSystemName,
nameEnvElts, realSrcSpanEnd, nameEnvElts, realSrcSpanEnd,
realSrcSpanStart, unitNameEnv) realSrcSpanStart, unitNameEnv)
import Development.IDE.GHC.Error import Development.IDE.GHC.Error
import Development.IDE.Types.Location import Development.IDE.Types.Location
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | Turn a 'RealSrcSpan' into an 'Interval'. -- | Turn a 'RealSrcSpan' into an 'Interval'.
realSrcSpanToInterval :: RealSrcSpan -> Interval Position realSrcSpanToInterval :: RealSrcSpan -> Interval Position
realSrcSpanToInterval rss = realSrcSpanToInterval rss =
Interval Interval
(realSrcLocToPosition $ realSrcSpanStart rss) (realSrcLocToPosition $ realSrcSpanStart rss)
(realSrcLocToPosition $ realSrcSpanEnd rss) (realSrcLocToPosition $ realSrcSpanEnd rss)
bindings :: RefMap Type -> Bindings bindings :: RefMap Type -> Bindings
bindings = uncurry Bindings . localBindings bindings = uncurry Bindings . localBindings
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | Compute which identifiers are in scope at every point in the AST. Use -- | Compute which identifiers are in scope at every point in the AST. Use
-- 'getLocalScope' to find the results. -- 'getLocalScope' to find the results.
localBindings localBindings
:: RefMap Type :: RefMap Type
-> ( IntervalMap Position (NameEnv (Name, Maybe Type)) -> ( IntervalMap Position (NameEnv (Name, Maybe Type))
, IntervalMap Position (NameEnv (Name, Maybe Type)) , IntervalMap Position (NameEnv (Name, Maybe Type))
) )
localBindings refmap = bimap mk mk $ unzip $ do localBindings refmap = bimap mk mk $ unzip $ do
(ident, refs) <- M.toList refmap (ident, refs) <- M.toList refmap
Right name <- pure ident Right name <- pure ident
(_, ident_details) <- refs (_, ident_details) <- refs
let ty = identType ident_details let ty = identType ident_details
info <- S.toList $ identInfo ident_details info <- S.toList $ identInfo ident_details
pure pure
( do ( do
Just scopes <- pure $ getScopeFromContext info Just scopes <- pure $ getScopeFromContext info
scope <- scopes >>= \case scope <- scopes >>= \case
LocalScope scope -> pure $ realSrcSpanToInterval scope LocalScope scope -> pure $ realSrcSpanToInterval scope
_ -> [] _ -> []
pure ( scope pure ( scope
, unitNameEnv name (name,ty) , unitNameEnv name (name,ty)
) )
, do , do
Just scope <- pure $ getBindSiteFromContext info Just scope <- pure $ getBindSiteFromContext info
pure ( realSrcSpanToInterval scope pure ( realSrcSpanToInterval scope
, unitNameEnv name (name,ty) , unitNameEnv name (name,ty)
) )
) )
where where
mk = L.foldl' (flip (uncurry IM.insert)) mempty . join mk = L.foldl' (flip (uncurry IM.insert)) mempty . join
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | The available bindings at every point in a Haskell tree. -- | The available bindings at every point in a Haskell tree.
data Bindings = Bindings data Bindings = Bindings
{ getLocalBindings { getLocalBindings
:: IntervalMap Position (NameEnv (Name, Maybe Type)) :: IntervalMap Position (NameEnv (Name, Maybe Type))
, getBindingSites , getBindingSites
:: IntervalMap Position (NameEnv (Name, Maybe Type)) :: IntervalMap Position (NameEnv (Name, Maybe Type))
} }
instance Semigroup Bindings where instance Semigroup Bindings where
Bindings a1 b1 <> Bindings a2 b2 Bindings a1 b1 <> Bindings a2 b2
= Bindings (a1 <> a2) (b1 <> b2) = Bindings (a1 <> a2) (b1 <> b2)
instance Monoid Bindings where instance Monoid Bindings where
mempty = Bindings mempty mempty mempty = Bindings mempty mempty
instance NFData Bindings where instance NFData Bindings where
rnf = rwhnf rnf = rwhnf
instance Show Bindings where instance Show Bindings where
show _ = "<bindings>" show _ = "<bindings>"
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | Given a 'Bindings' get every identifier in scope at the given -- | Given a 'Bindings' get every identifier in scope at the given
-- 'RealSrcSpan', -- 'RealSrcSpan',
getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)]
getLocalScope bs rss getLocalScope bs rss
= nameEnvElts = nameEnvElts
$ foldMap snd $ foldMap snd
$ IM.dominators (realSrcSpanToInterval rss) $ IM.dominators (realSrcSpanToInterval rss)
$ getLocalBindings bs $ getLocalBindings bs
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | Given a 'Bindings', get every binding currently active at a given -- | Given a 'Bindings', get every binding currently active at a given
-- 'RealSrcSpan', -- 'RealSrcSpan',
getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)]
getDefiningBindings bs rss getDefiningBindings bs rss
= nameEnvElts = nameEnvElts
$ foldMap snd $ foldMap snd
$ IM.dominators (realSrcSpanToInterval rss) $ IM.dominators (realSrcSpanToInterval rss)
$ getBindingSites bs $ getBindingSites bs
-- | Lookup all names in scope in any span that intersects the interval -- | Lookup all names in scope in any span that intersects the interval
-- defined by the two positions. -- defined by the two positions.
-- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping` -- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping`
getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)] getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)]
getFuzzyScope bs a b getFuzzyScope bs a b
= filter (not . isSystemName . fst) = filter (not . isSystemName . fst)
$ nameEnvElts $ nameEnvElts
$ foldMap snd $ foldMap snd
$ IM.intersections (Interval a b) $ IM.intersections (Interval a b)
$ getLocalBindings bs $ getLocalBindings bs
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | Given a 'Bindings', get every binding that intersects the interval defined -- | Given a 'Bindings', get every binding that intersects the interval defined
-- by the two positions. -- by the two positions.
-- This is meant for use with the fuzzy `PositionRange` returned by -- This is meant for use with the fuzzy `PositionRange` returned by
-- `PositionMapping` -- `PositionMapping`
getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)] getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)]
getFuzzyDefiningBindings bs a b getFuzzyDefiningBindings bs a b
= nameEnvElts = nameEnvElts
$ foldMap snd $ foldMap snd
$ IM.intersections (Interval a b) $ IM.intersections (Interval a b)
$ getBindingSites bs $ getBindingSites bs

306
ghcide/src/Development/IDE/Types/HscEnvEq.hs
View File

@ -1,153 +1,153 @@
module Development.IDE.Types.HscEnvEq module Development.IDE.Types.HscEnvEq
( HscEnvEq, ( HscEnvEq,
hscEnv, newHscEnvEq, hscEnv, newHscEnvEq,
hscEnvWithImportPaths, hscEnvWithImportPaths,
newHscEnvEqPreserveImportPaths, newHscEnvEqPreserveImportPaths,
newHscEnvEqWithImportPaths, newHscEnvEqWithImportPaths,
envImportPaths, envImportPaths,
envPackageExports, envPackageExports,
envVisibleModuleNames, envVisibleModuleNames,
deps deps
) where ) where
import Control.Concurrent.Async (Async, async, waitCatch) import Control.Concurrent.Async (Async, async, waitCatch)
import Control.Concurrent.Strict (modifyVar, newVar) import Control.Concurrent.Strict (modifyVar, newVar)
import Control.DeepSeq (force) import Control.DeepSeq (force)
import Control.Exception (evaluate, mask, throwIO) import Control.Exception (evaluate, mask, throwIO)
import Control.Monad.Extra (eitherM, join, mapMaybeM) import Control.Monad.Extra (eitherM, join, mapMaybeM)
import Data.Either (fromRight) import Data.Either (fromRight)
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Unique (Unique) import Data.Unique (Unique)
import qualified Data.Unique as Unique import qualified Data.Unique as Unique
import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat
import qualified Development.IDE.GHC.Compat.Util as Maybes import qualified Development.IDE.GHC.Compat.Util as Maybes
import Development.IDE.GHC.Error (catchSrcErrors) import Development.IDE.GHC.Error (catchSrcErrors)
import Development.IDE.GHC.Util (lookupPackageConfig) import Development.IDE.GHC.Util (lookupPackageConfig)
import Development.IDE.Graph.Classes import Development.IDE.Graph.Classes
import Development.IDE.Types.Exports (ExportsMap, createExportsMap) import Development.IDE.Types.Exports (ExportsMap, createExportsMap)
import OpenTelemetry.Eventlog (withSpan) import OpenTelemetry.Eventlog (withSpan)
import System.Directory (makeAbsolute) import System.Directory (makeAbsolute)
import System.FilePath import System.FilePath
-- | An 'HscEnv' with equality. Two values are considered equal -- | An 'HscEnv' with equality. Two values are considered equal
-- if they are created with the same call to 'newHscEnvEq'. -- if they are created with the same call to 'newHscEnvEq'.
data HscEnvEq = HscEnvEq data HscEnvEq = HscEnvEq
{ envUnique :: !Unique { envUnique :: !Unique
, hscEnv :: !HscEnv , hscEnv :: !HscEnv
, deps :: [(UnitId, DynFlags)] , deps :: [(UnitId, DynFlags)]
-- ^ In memory components for this HscEnv -- ^ In memory components for this HscEnv
-- This is only used at the moment for the import dirs in -- This is only used at the moment for the import dirs in
-- the DynFlags -- the DynFlags
, envImportPaths :: Maybe (Set FilePath) , envImportPaths :: Maybe (Set FilePath)
-- ^ If Just, import dirs originally configured in this env -- ^ If Just, import dirs originally configured in this env
-- If Nothing, the env import dirs are unaltered -- If Nothing, the env import dirs are unaltered
, envPackageExports :: IO ExportsMap , envPackageExports :: IO ExportsMap
, envVisibleModuleNames :: IO (Maybe [ModuleName]) , envVisibleModuleNames :: IO (Maybe [ModuleName])
-- ^ 'listVisibleModuleNames' is a pure function, -- ^ 'listVisibleModuleNames' is a pure function,
-- but it could panic due to a ghc bug: https://github.com/haskell/haskell-language-server/issues/1365 -- but it could panic due to a ghc bug: https://github.com/haskell/haskell-language-server/issues/1365
-- So it's wrapped in IO here for error handling -- So it's wrapped in IO here for error handling
-- If Nothing, 'listVisibleModuleNames' panic -- If Nothing, 'listVisibleModuleNames' panic
} }
-- | Wrap an 'HscEnv' into an 'HscEnvEq'. -- | Wrap an 'HscEnv' into an 'HscEnvEq'.
newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEq cradlePath hscEnv0 deps = do newHscEnvEq cradlePath hscEnv0 deps = do
let relativeToCradle = (takeDirectory cradlePath </>) let relativeToCradle = (takeDirectory cradlePath </>)
hscEnv = removeImportPaths hscEnv0 hscEnv = removeImportPaths hscEnv0
-- Make Absolute since targets are also absolute -- Make Absolute since targets are also absolute
importPathsCanon <- importPathsCanon <-
mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0)
newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps
newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do
let dflags = hsc_dflags hscEnv let dflags = hsc_dflags hscEnv
envUnique <- Unique.newUnique envUnique <- Unique.newUnique
-- it's very important to delay the package exports computation -- it's very important to delay the package exports computation
envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do
-- compute the package imports -- compute the package imports
let pkgst = unitState hscEnv let pkgst = unitState hscEnv
depends = explicitUnits pkgst depends = explicitUnits pkgst
modules = modules =
[ m [ m
| d <- depends | d <- depends
, Just pkg <- [lookupPackageConfig d hscEnv] , Just pkg <- [lookupPackageConfig d hscEnv]
, (modName, maybeOtherPkgMod) <- unitExposedModules pkg , (modName, maybeOtherPkgMod) <- unitExposedModules pkg
, let m = case maybeOtherPkgMod of , let m = case maybeOtherPkgMod of
-- When module is re-exported from another package, -- When module is re-exported from another package,
-- the origin module is represented by value in Just -- the origin module is represented by value in Just
Just otherPkgMod -> otherPkgMod Just otherPkgMod -> otherPkgMod
Nothing -> mkModule (unitInfoId pkg) modName Nothing -> mkModule (unitInfoId pkg) modName
] ]
doOne m = do doOne m = do
modIface <- initIfaceLoad hscEnv $ modIface <- initIfaceLoad hscEnv $
loadInterface "" m (ImportByUser NotBoot) loadInterface "" m (ImportByUser NotBoot)
return $ case modIface of return $ case modIface of
Maybes.Failed _r -> Nothing Maybes.Failed _r -> Nothing
Maybes.Succeeded mi -> Just mi Maybes.Succeeded mi -> Just mi
modIfaces <- mapMaybeM doOne modules modIfaces <- mapMaybeM doOne modules
return $ createExportsMap modIfaces return $ createExportsMap modIfaces
-- similar to envPackageExports, evaluated lazily -- similar to envPackageExports, evaluated lazily
envVisibleModuleNames <- onceAsync $ envVisibleModuleNames <- onceAsync $
fromRight Nothing fromRight Nothing
<$> catchSrcErrors <$> catchSrcErrors
dflags dflags
"listVisibleModuleNames" "listVisibleModuleNames"
(evaluate . force . Just $ listVisibleModuleNames hscEnv) (evaluate . force . Just $ listVisibleModuleNames hscEnv)
return HscEnvEq{..} return HscEnvEq{..}
-- | Wrap an 'HscEnv' into an 'HscEnvEq'. -- | Wrap an 'HscEnv' into an 'HscEnvEq'.
newHscEnvEqPreserveImportPaths newHscEnvEqPreserveImportPaths
:: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq :: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing
-- | Unwrap the 'HscEnv' with the original import paths. -- | Unwrap the 'HscEnv' with the original import paths.
-- Used only for locating imports -- Used only for locating imports
hscEnvWithImportPaths :: HscEnvEq -> HscEnv hscEnvWithImportPaths :: HscEnvEq -> HscEnv
hscEnvWithImportPaths HscEnvEq{..} hscEnvWithImportPaths HscEnvEq{..}
| Just imps <- envImportPaths | Just imps <- envImportPaths
= hscSetFlags (setImportPaths (Set.toList imps) (hsc_dflags hscEnv)) hscEnv = hscSetFlags (setImportPaths (Set.toList imps) (hsc_dflags hscEnv)) hscEnv
| otherwise | otherwise
= hscEnv = hscEnv
removeImportPaths :: HscEnv -> HscEnv removeImportPaths :: HscEnv -> HscEnv
removeImportPaths hsc = hscSetFlags (setImportPaths [] (hsc_dflags hsc)) hsc removeImportPaths hsc = hscSetFlags (setImportPaths [] (hsc_dflags hsc)) hsc
instance Show HscEnvEq where instance Show HscEnvEq where
show HscEnvEq{envUnique} = "HscEnvEq " ++ show (Unique.hashUnique envUnique) show HscEnvEq{envUnique} = "HscEnvEq " ++ show (Unique.hashUnique envUnique)
instance Eq HscEnvEq where instance Eq HscEnvEq where
a == b = envUnique a == envUnique b a == b = envUnique a == envUnique b
instance NFData HscEnvEq where instance NFData HscEnvEq where
rnf (HscEnvEq a b c d _ _) = rnf (HscEnvEq a b c d _ _) =
-- deliberately skip the package exports map and visible module names -- deliberately skip the package exports map and visible module names
rnf (Unique.hashUnique a) `seq` b `seq` c `seq` rnf d rnf (Unique.hashUnique a) `seq` b `seq` c `seq` rnf d
instance Hashable HscEnvEq where instance Hashable HscEnvEq where
hashWithSalt s = hashWithSalt s . envUnique hashWithSalt s = hashWithSalt s . envUnique
-- | Given an action, produce a wrapped action that runs at most once. -- | Given an action, produce a wrapped action that runs at most once.
-- The action is run in an async so it won't be killed by async exceptions -- The action is run in an async so it won't be killed by async exceptions
-- If the function raises an exception, the same exception will be reraised each time. -- If the function raises an exception, the same exception will be reraised each time.
onceAsync :: IO a -> IO (IO a) onceAsync :: IO a -> IO (IO a)
onceAsync act = do onceAsync act = do
var <- newVar OncePending var <- newVar OncePending
let run as = eitherM throwIO pure (waitCatch as) let run as = eitherM throwIO pure (waitCatch as)
pure $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of pure $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of
OnceRunning x -> pure (v, unmask $ run x) OnceRunning x -> pure (v, unmask $ run x)
OncePending -> do OncePending -> do
x <- async (unmask act) x <- async (unmask act)
pure (OnceRunning x, unmask $ run x) pure (OnceRunning x, unmask $ run x)
data Once a = OncePending | OnceRunning (Async a) data Once a = OncePending | OnceRunning (Async a)

248
ghcide/src/Generics/SYB/GHC.hs
View File

@ -1,124 +1,124 @@
{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DerivingVia #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
-- | Custom SYB traversals explicitly designed for operating over the GHC AST. -- | Custom SYB traversals explicitly designed for operating over the GHC AST.
module Generics.SYB.GHC module Generics.SYB.GHC
( genericIsSubspan, ( genericIsSubspan,
mkBindListT, mkBindListT,
everywhereM', everywhereM',
smallestM, smallestM,
largestM largestM
) where ) where
import Control.Monad import Control.Monad
import Data.Functor.Compose (Compose (Compose)) import Data.Functor.Compose (Compose (Compose))
import Data.Monoid (Any (Any)) import Data.Monoid (Any (Any))
import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat
import Development.IDE.Graph.Classes import Development.IDE.Graph.Classes
import Generics.SYB import Generics.SYB
-- | A generic query intended to be used for calling 'smallestM' and -- | A generic query intended to be used for calling 'smallestM' and
-- 'largestM'. If the current node is a 'Located', returns whether or not the -- 'largestM'. If the current node is a 'Located', returns whether or not the
-- given 'SrcSpan' is a subspan. For all other nodes, returns 'Nothing', which -- given 'SrcSpan' is a subspan. For all other nodes, returns 'Nothing', which
-- indicates uncertainty. The search strategy in 'smallestM' et al. will -- indicates uncertainty. The search strategy in 'smallestM' et al. will
-- continue searching uncertain nodes. -- continue searching uncertain nodes.
genericIsSubspan :: genericIsSubspan ::
forall ast. forall ast.
Typeable ast => Typeable ast =>
-- | The type of nodes we'd like to consider. -- | The type of nodes we'd like to consider.
Proxy (Located ast) -> Proxy (Located ast) ->
SrcSpan -> SrcSpan ->
GenericQ (Maybe (Bool, ast)) GenericQ (Maybe (Bool, ast))
genericIsSubspan _ dst = mkQ Nothing $ \case genericIsSubspan _ dst = mkQ Nothing $ \case
(L span ast :: Located ast) -> Just (dst `isSubspanOf` span, ast) (L span ast :: Located ast) -> Just (dst `isSubspanOf` span, ast)
-- | Lift a function that replaces a value with several values into a generic -- | Lift a function that replaces a value with several values into a generic
-- function. The result doesn't perform any searching, so should be driven via -- function. The result doesn't perform any searching, so should be driven via
-- 'everywhereM' or friends. -- 'everywhereM' or friends.
-- --
-- The 'Int' argument is the index in the list being bound. -- The 'Int' argument is the index in the list being bound.
mkBindListT :: forall b m. (Data b, Monad m) => (Int -> b -> m [b]) -> GenericM m mkBindListT :: forall b m. (Data b, Monad m) => (Int -> b -> m [b]) -> GenericM m
mkBindListT f = mkM $ fmap join . traverse (uncurry f) . zip [0..] mkBindListT f = mkM $ fmap join . traverse (uncurry f) . zip [0..]
-- | Apply a monadic transformation everywhere in a top-down manner. -- | Apply a monadic transformation everywhere in a top-down manner.
everywhereM' :: forall m. Monad m => GenericM m -> GenericM m everywhereM' :: forall m. Monad m => GenericM m -> GenericM m
everywhereM' f = go everywhereM' f = go
where where
go :: GenericM m go :: GenericM m
go = gmapM go <=< f go = gmapM go <=< f
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- Custom SYB machinery -- Custom SYB machinery
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | Generic monadic transformations that return side-channel data. -- | Generic monadic transformations that return side-channel data.
type GenericMQ r m = forall a. Data a => a -> m (r, a) type GenericMQ r m = forall a. Data a => a -> m (r, a)
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | Apply the given 'GenericM' at all every node whose children fail the -- | Apply the given 'GenericM' at all every node whose children fail the
-- 'GenericQ', but which passes the query itself. -- 'GenericQ', but which passes the query itself.
-- --
-- The query must be a monotonic function when it returns 'Just'. That is, if -- The query must be a monotonic function when it returns 'Just'. That is, if
-- @s@ is a subtree of @t@, @q t@ should return @Just True@ if @q s@ does. It -- @s@ is a subtree of @t@, @q t@ should return @Just True@ if @q s@ does. It
-- is the True-to-false edge of the query that triggers the transformation. -- is the True-to-false edge of the query that triggers the transformation.
-- --
-- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes -- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes
-- with data nodes, so for any given node we can only definitely return an -- with data nodes, so for any given node we can only definitely return an
-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is -- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is
-- used. -- used.
smallestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m smallestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m
smallestM q f = fmap snd . go smallestM q f = fmap snd . go
where where
go :: GenericMQ Any m go :: GenericMQ Any m
go x = do go x = do
case q x of case q x of
Nothing -> gmapMQ go x Nothing -> gmapMQ go x
Just (True, a) -> do Just (True, a) -> do
it@(r, x') <- gmapMQ go x it@(r, x') <- gmapMQ go x
case r of case r of
Any True -> pure it Any True -> pure it
Any False -> fmap (Any True,) $ f a x' Any False -> fmap (Any True,) $ f a x'
Just (False, _) -> pure (mempty, x) Just (False, _) -> pure (mempty, x)
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but -- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but
-- don't descend into children if the query matches. Because this traversal is -- don't descend into children if the query matches. Because this traversal is
-- root-first, this policy will find the largest subtrees for which the query -- root-first, this policy will find the largest subtrees for which the query
-- holds true. -- holds true.
-- --
-- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes -- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes
-- with data nodes, so for any given node we can only definitely return an -- with data nodes, so for any given node we can only definitely return an
-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is -- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is
-- used. -- used.
largestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m largestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m
largestM q f = go largestM q f = go
where where
go :: GenericM m go :: GenericM m
go x = do go x = do
case q x of case q x of
Just (True, a) -> f a x Just (True, a) -> f a x
Just (False, _) -> pure x Just (False, _) -> pure x
Nothing -> gmapM go x Nothing -> gmapM go x
newtype MonadicQuery r m a = MonadicQuery newtype MonadicQuery r m a = MonadicQuery
{ runMonadicQuery :: m (r, a) { runMonadicQuery :: m (r, a)
} }
deriving stock (Functor) deriving stock (Functor)
deriving Applicative via Compose m ((,) r) deriving Applicative via Compose m ((,) r)
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- | Like 'gmapM', but also returns side-channel data. -- | Like 'gmapM', but also returns side-channel data.
gmapMQ :: gmapMQ ::
forall f r a. (Monoid r, Data a, Applicative f) => forall f r a. (Monoid r, Data a, Applicative f) =>
(forall d. Data d => d -> f (r, d)) -> (forall d. Data d => d -> f (r, d)) ->
a -> a ->
f (r, a) f (r, a)
gmapMQ f = runMonadicQuery . gfoldl k pure gmapMQ f = runMonadicQuery . gfoldl k pure
where where
k :: Data d => MonadicQuery r f (d -> b) -> d -> MonadicQuery r f b k :: Data d => MonadicQuery r f (d -> b) -> d -> MonadicQuery r f b
k c x = c <*> MonadicQuery (f x) k c x = c <*> MonadicQuery (f x)

478
hls-graph/html/ts/jquery.flot.d.ts vendored
View File

@ -1,240 +1,240 @@
// Type definitions for Flot // Type definitions for Flot
// Project: http://www.flotcharts.org/ // Project: http://www.flotcharts.org/
// Definitions by: Matt Burland <https://github.com/burlandm> // Definitions by: Matt Burland <https://github.com/burlandm>
// Definitions: https://github.com/borisyankov/DefinitelyTyped // Definitions: https://github.com/borisyankov/DefinitelyTyped
declare module jquery.flot { declare module jquery.flot {
interface plotOptions { interface plotOptions {
colors?: any[]; colors?: any[];
series?: seriesOptions; series?: seriesOptions;
legend?: legendOptions; legend?: legendOptions;
xaxis?: axisOptions; xaxis?: axisOptions;
yaxis?: axisOptions; yaxis?: axisOptions;
xaxes?: axisOptions[]; xaxes?: axisOptions[];
yaxes?: axisOptions[]; yaxes?: axisOptions[];
grid?: gridOptions; grid?: gridOptions;
interaction?: interaction; interaction?: interaction;
hooks?: hooks; hooks?: hooks;
} }
interface hooks { interface hooks {
processOptions: { (plot: plot, options: plotOptions): void; } []; processOptions: { (plot: plot, options: plotOptions): void; } [];
processRawData: { (plot: plot, series: dataSeries, data: any[], datapoints: datapoints): void; }[]; processRawData: { (plot: plot, series: dataSeries, data: any[], datapoints: datapoints): void; }[];
processDatapoints: { (plot: plot, series: dataSeries, datapoints: datapoints): void; }[]; processDatapoints: { (plot: plot, series: dataSeries, datapoints: datapoints): void; }[];
processOffset: { (plot: plot, offset: canvasPoint): void; }[]; processOffset: { (plot: plot, offset: canvasPoint): void; }[];
drawBackground: { (plot: plot, context: CanvasRenderingContext2D): void; }[]; drawBackground: { (plot: plot, context: CanvasRenderingContext2D): void; }[];
drawSeries: { (plot: plot, context: CanvasRenderingContext2D, series: dataSeries): void; }[]; drawSeries: { (plot: plot, context: CanvasRenderingContext2D, series: dataSeries): void; }[];
draw: { (plot: plot, context: CanvasRenderingContext2D): void; }[]; draw: { (plot: plot, context: CanvasRenderingContext2D): void; }[];
bindEvents: { (plot: plot, eventHolder: JQuery): void; }[]; bindEvents: { (plot: plot, eventHolder: JQuery): void; }[];
drawOverlay: { (plot: plot, context: CanvasRenderingContext2D): void; }[]; drawOverlay: { (plot: plot, context: CanvasRenderingContext2D): void; }[];
shutdown: { (plot: plot, eventHolder: JQuery): void; }[]; shutdown: { (plot: plot, eventHolder: JQuery): void; }[];
} }
interface interaction { interface interaction {
redrawOverlayInterval?: number; redrawOverlayInterval?: number;
} }
interface gridOptions { interface gridOptions {
show?: boolean; show?: boolean;
aboveData?: boolean; aboveData?: boolean;
color?: any; // color color?: any; // color
backgroundColor?: any; //color/gradient or null backgroundColor?: any; //color/gradient or null
margin?: any; // number or margin object margin?: any; // number or margin object
labelMargin?: number; labelMargin?: number;
axisMargin?: number; axisMargin?: number;
markings?: any; //array of markings or (fn: axes -> array of markings) markings?: any; //array of markings or (fn: axes -> array of markings)
borderWidth?: any; // number or width object borderWidth?: any; // number or width object
borderColor?: any; // color or null borderColor?: any; // color or null
minBorderMargin?: number; // or null minBorderMargin?: number; // or null
clickable?: boolean; clickable?: boolean;
hoverable?: boolean; hoverable?: boolean;
autoHighlight?: boolean; autoHighlight?: boolean;
mouseActiveRadius?: number; mouseActiveRadius?: number;
tickColor?: any; tickColor?: any;
markingsColor?: any; markingsColor?: any;
markingsLineWidth?: number; markingsLineWidth?: number;
} }
interface legendOptions { interface legendOptions {
show?: boolean; show?: boolean;
labelFormatter?: (label: string, series: any) => string; // null or (fn: string, series object -> string) labelFormatter?: (label: string, series: any) => string; // null or (fn: string, series object -> string)
labelBoxBorderColor?: any; //color labelBoxBorderColor?: any; //color
noColumns?: number; noColumns?: number;
position?: string; //"ne" or "nw" or "se" or "sw" position?: string; //"ne" or "nw" or "se" or "sw"
margin?: any; //number of pixels or [x margin, y margin] margin?: any; //number of pixels or [x margin, y margin]
backgroundColor?: any; //null or color backgroundColor?: any; //null or color
backgroundOpacity?: number; // between 0 and 1 backgroundOpacity?: number; // between 0 and 1
container?: JQuery; // null or jQuery object/DOM element/jQuery expression container?: JQuery; // null or jQuery object/DOM element/jQuery expression
sorted?: any; //null/false, true, "ascending", "descending" or a comparator sorted?: any; //null/false, true, "ascending", "descending" or a comparator
} }
interface seriesOptions { interface seriesOptions {
color?: any; // color or number color?: any; // color or number
label?: string; label?: string;
lines?: linesOptions; lines?: linesOptions;
bars?: barsOptions; bars?: barsOptions;
points?: pointsOptions; points?: pointsOptions;
xaxis?: number; xaxis?: number;
yaxis?: number; yaxis?: number;
clickable?: boolean; clickable?: boolean;
hoverable?: boolean; hoverable?: boolean;
shadowSize?: number; shadowSize?: number;
highlightColor?: any; highlightColor?: any;
stack?: boolean; // NEIL: Since we use the Stack plugin stack?: boolean; // NEIL: Since we use the Stack plugin
} }
interface dataSeries extends seriesOptions { interface dataSeries extends seriesOptions {
data: any[]; data: any[];
} }
interface axisOptions { interface axisOptions {
show?: boolean; // null or true/false show?: boolean; // null or true/false
position?: string; // "bottom" or "top" or "left" or "right" position?: string; // "bottom" or "top" or "left" or "right"
color?: any; // null or color spec color?: any; // null or color spec
tickColor?: any; // null or color spec tickColor?: any; // null or color spec
font?: any; // null or font spec object font?: any; // null or font spec object
min?: number; min?: number;
max?: number; max?: number;
autoscaleMargin?: number; autoscaleMargin?: number;
transform?: (v: number) => number; // null or fn: number -> number transform?: (v: number) => number; // null or fn: number -> number
inverseTransform?: (v: number) => number; // null or fn: number -> number inverseTransform?: (v: number) => number; // null or fn: number -> number
ticks?: any; // null or number or ticks array or (fn: axis -> ticks array) ticks?: any; // null or number or ticks array or (fn: axis -> ticks array)
tickSize?: any; // number or array tickSize?: any; // number or array
minTickSize?: any; // number or array minTickSize?: any; // number or array
tickFormatter?: (t: number, a?: axis) => string; // (fn: number, object -> string) or string tickFormatter?: (t: number, a?: axis) => string; // (fn: number, object -> string) or string
tickDecimals?: number; tickDecimals?: number;
labelWidth?: number; labelWidth?: number;
labelHeight?: number; labelHeight?: number;
reserveSpace?: boolean; reserveSpace?: boolean;
tickLength?: number; tickLength?: number;
alignTicksWithAxis?: number; alignTicksWithAxis?: number;
} }
interface seriesTypeBase { interface seriesTypeBase {
show?: boolean; show?: boolean;
lineWidth?: number; lineWidth?: number;
fill?: any; //boolean or number fill?: any; //boolean or number
fillColor?: any; //null or color/gradient fillColor?: any; //null or color/gradient
} }
interface linesOptions extends seriesTypeBase { interface linesOptions extends seriesTypeBase {
steps?: boolean; steps?: boolean;
} }
interface barsOptions extends seriesTypeBase { interface barsOptions extends seriesTypeBase {
barWidth?: number; barWidth?: number;
align?: string; align?: string;
horizontal?: boolean; horizontal?: boolean;
} }
interface pointsOptions extends seriesTypeBase { interface pointsOptions extends seriesTypeBase {
radius?: number; radius?: number;
symbol?: any; symbol?: any;
} }
interface gradient { interface gradient {
colors: any[]; colors: any[];
} }
interface item { interface item {
datapoint: number[]; // the point, e.g. [0, 2] datapoint: number[]; // the point, e.g. [0, 2]
dataIndex: number; // the index of the point in the data array dataIndex: number; // the index of the point in the data array
series: dataSeries; //the series object series: dataSeries; //the series object
seriesIndex: number; //the index of the series seriesIndex: number; //the index of the series
pageX: number; pageX: number;
pageY: number; //the global screen coordinates of the point pageY: number; //the global screen coordinates of the point
} }
interface datapoints { interface datapoints {
points: number[]; points: number[];
pointsize: number; pointsize: number;
format: datapointFormat[]; format: datapointFormat[];
} }
interface datapointFormat { interface datapointFormat {
x?: boolean; x?: boolean;
y?: boolean; y?: boolean;
number: boolean; number: boolean;
required: boolean; required: boolean;
defaultValue?: number; defaultValue?: number;
} }
interface point { interface point {
x: number; x: number;
y: number; y: number;
} }
interface offset { interface offset {
left: number; left: number;
top: number; top: number;
} }
interface canvasPoint { interface canvasPoint {
top: number; top: number;
left: number; left: number;
bottom?: number; bottom?: number;
right?: number; right?: number;
} }
interface axes { interface axes {
xaxis: axis; xaxis: axis;
yaxis: axis; yaxis: axis;
x2axis?: axis; x2axis?: axis;
y2axis?: axis; y2axis?: axis;
} }
interface axis extends axisOptions { interface axis extends axisOptions {
options: axisOptions; options: axisOptions;
p2c(point: point):canvasPoint; p2c(point: point):canvasPoint;
c2p(canvasPoint: canvasPoint):point; c2p(canvasPoint: canvasPoint):point;
} }
interface plugin { interface plugin {
init(options: plotOptions): any; init(options: plotOptions): any;
options?: any; options?: any;
name?: string; name?: string;
version?: string; version?: string;
} }
interface plot { interface plot {
highlight(series: dataSeries, datapoint: item): void; highlight(series: dataSeries, datapoint: item): void;
unhighlight(): void; unhighlight(): void;
unhighlight(series: dataSeries, datapoint: item): void; unhighlight(series: dataSeries, datapoint: item): void;
setData(data: any): void; setData(data: any): void;
setupGrid(): void; setupGrid(): void;
draw(): void; draw(): void;
triggerRedrawOverlay(): void; triggerRedrawOverlay(): void;
width(): number; width(): number;
height(): number; height(): number;
offset(): JQueryCoordinates; offset(): JQueryCoordinates;
pointOffset(point: point): offset; pointOffset(point: point): offset;
resize(): void; resize(): void;
shutdown(): void; shutdown(): void;
getData(): dataSeries[]; getData(): dataSeries[];
getAxes(): axes; getAxes(): axes;
getXAxes(): axis[]; getXAxes(): axis[];
getYAxes(): axis[]; getYAxes(): axis[];
getPlaceholder(): JQuery; getPlaceholder(): JQuery;
getCanvas(): HTMLCanvasElement; getCanvas(): HTMLCanvasElement;
getPlotOffset(): canvasPoint; getPlotOffset(): canvasPoint;
getOptions(): plotOptions; getOptions(): plotOptions;
} }
interface plotStatic { interface plotStatic {
(placeholder: JQuery, data: dataSeries[], options?: plotOptions): plot; (placeholder: JQuery, data: dataSeries[], options?: plotOptions): plot;
(placeholder: JQuery, data: any[], options?: plotOptions): plot; (placeholder: JQuery, data: any[], options?: plotOptions): plot;
plugins: plugin[]; plugins: plugin[];
} }
} }
interface JQueryStatic { interface JQueryStatic {
plot: jquery.flot.plotStatic; plot: jquery.flot.plotStatic;
} }

16
hls-graph/src/Development/IDE/Graph/Classes.hs
View File

@ -1,8 +1,8 @@
module Development.IDE.Graph.Classes( module Development.IDE.Graph.Classes(
Show(..), Typeable, Eq(..), Hashable(..), NFData(..) Show(..), Typeable, Eq(..), Hashable(..), NFData(..)
) where ) where
import Control.DeepSeq import Control.DeepSeq
import Data.Hashable import Data.Hashable
import Data.Typeable import Data.Typeable

274
hls-graph/src/Development/IDE/Graph/Internal/Action.hs
View File

@ -1,137 +1,137 @@
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Development.IDE.Graph.Internal.Action module Development.IDE.Graph.Internal.Action
( ShakeValue ( ShakeValue
, actionFork , actionFork
, actionBracket , actionBracket
, actionCatch , actionCatch
, actionFinally , actionFinally
, alwaysRerun , alwaysRerun
, apply1 , apply1
, apply , apply
, parallel , parallel
, reschedule , reschedule
, runActions , runActions
, Development.IDE.Graph.Internal.Action.getDirtySet , Development.IDE.Graph.Internal.Action.getDirtySet
, getKeysAndVisitedAge , getKeysAndVisitedAge
) where ) where
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Exception import Control.Exception
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.IORef import Data.IORef
import Development.IDE.Graph.Classes import Development.IDE.Graph.Classes
import Development.IDE.Graph.Internal.Database import Development.IDE.Graph.Internal.Database
import Development.IDE.Graph.Internal.Rules (RuleResult) import Development.IDE.Graph.Internal.Rules (RuleResult)
import Development.IDE.Graph.Internal.Types import Development.IDE.Graph.Internal.Types
import System.Exit import System.Exit
type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a) type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
-- | Always rerun this rule when dirty, regardless of the dependencies. -- | Always rerun this rule when dirty, regardless of the dependencies.
alwaysRerun :: Action () alwaysRerun :: Action ()
alwaysRerun = do alwaysRerun = do
ref <- Action $ asks actionDeps ref <- Action $ asks actionDeps
liftIO $ modifyIORef ref (AlwaysRerunDeps [] <>) liftIO $ modifyIORef ref (AlwaysRerunDeps [] <>)
-- No-op for now -- No-op for now
reschedule :: Double -> Action () reschedule :: Double -> Action ()
reschedule _ = pure () reschedule _ = pure ()
parallel :: [Action a] -> Action [a] parallel :: [Action a] -> Action [a]
parallel [] = pure [] parallel [] = pure []
parallel [x] = fmap (:[]) x parallel [x] = fmap (:[]) x
parallel xs = do parallel xs = do
a <- Action ask a <- Action ask
deps <- liftIO $ readIORef $ actionDeps a deps <- liftIO $ readIORef $ actionDeps a
case deps of case deps of
UnknownDeps -> UnknownDeps ->
-- if we are already in the rerun mode, nothing we do is going to impact our state -- if we are already in the rerun mode, nothing we do is going to impact our state
liftIO $ mapConcurrently (ignoreState a) xs liftIO $ mapConcurrently (ignoreState a) xs
deps -> do deps -> do
(newDeps, res) <- liftIO $ unzip <$> mapConcurrently (usingState a) xs (newDeps, res) <- liftIO $ unzip <$> mapConcurrently (usingState a) xs
liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps
pure res pure res
where where
usingState a x = do usingState a x = do
ref <- newIORef mempty ref <- newIORef mempty
res <- runReaderT (fromAction x) a{actionDeps=ref} res <- runReaderT (fromAction x) a{actionDeps=ref}
deps <- readIORef ref deps <- readIORef ref
pure (deps, res) pure (deps, res)
ignoreState :: SAction -> Action b -> IO b ignoreState :: SAction -> Action b -> IO b
ignoreState a x = do ignoreState a x = do
ref <- newIORef mempty ref <- newIORef mempty
runReaderT (fromAction x) a{actionDeps=ref} runReaderT (fromAction x) a{actionDeps=ref}
actionFork :: Action a -> (Async a -> Action b) -> Action b actionFork :: Action a -> (Async a -> Action b) -> Action b
actionFork act k = do actionFork act k = do
a <- Action ask a <- Action ask
deps <- liftIO $ readIORef $ actionDeps a deps <- liftIO $ readIORef $ actionDeps a
let db = actionDatabase a let db = actionDatabase a
case deps of case deps of
UnknownDeps -> do UnknownDeps -> do
-- if we are already in the rerun mode, nothing we do is going to impact our state -- if we are already in the rerun mode, nothing we do is going to impact our state
[res] <- liftIO $ withAsync (ignoreState a act) $ \as -> runActions db [k as] [res] <- liftIO $ withAsync (ignoreState a act) $ \as -> runActions db [k as]
return res return res
_ -> _ ->
error "please help me" error "please help me"
isAsyncException :: SomeException -> Bool isAsyncException :: SomeException -> Bool
isAsyncException e isAsyncException e
| Just (_ :: AsyncCancelled) <- fromException e = True | Just (_ :: AsyncCancelled) <- fromException e = True
| Just (_ :: AsyncException) <- fromException e = True | Just (_ :: AsyncException) <- fromException e = True
| Just (_ :: ExitCode) <- fromException e = True | Just (_ :: ExitCode) <- fromException e = True
| otherwise = False | otherwise = False
actionCatch :: Exception e => Action a -> (e -> Action a) -> Action a actionCatch :: Exception e => Action a -> (e -> Action a) -> Action a
actionCatch a b = do actionCatch a b = do
v <- Action ask v <- Action ask
Action $ lift $ catchJust f (runReaderT (fromAction a) v) (\x -> runReaderT (fromAction (b x)) v) Action $ lift $ catchJust f (runReaderT (fromAction a) v) (\x -> runReaderT (fromAction (b x)) v)
where where
-- Catch only catches exceptions that were caused by this code, not those that -- Catch only catches exceptions that were caused by this code, not those that
-- are a result of program termination -- are a result of program termination
f e | isAsyncException e = Nothing f e | isAsyncException e = Nothing
| otherwise = fromException e | otherwise = fromException e
actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracket a b c = do actionBracket a b c = do
v <- Action ask v <- Action ask
Action $ lift $ bracket a b (\x -> runReaderT (fromAction (c x)) v) Action $ lift $ bracket a b (\x -> runReaderT (fromAction (c x)) v)
actionFinally :: Action a -> IO b -> Action a actionFinally :: Action a -> IO b -> Action a
actionFinally a b = do actionFinally a b = do
v <- Action ask v <- Action ask
Action $ lift $ finally (runReaderT (fromAction a) v) b Action $ lift $ finally (runReaderT (fromAction a) v) b
apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value
apply1 k = head <$> apply [k] apply1 k = head <$> apply [k]
apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value] apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value]
apply ks = do apply ks = do
db <- Action $ asks actionDatabase db <- Action $ asks actionDatabase
(is, vs) <- liftIO $ build db ks (is, vs) <- liftIO $ build db ks
ref <- Action $ asks actionDeps ref <- Action $ asks actionDeps
liftIO $ modifyIORef ref (ResultDeps is <>) liftIO $ modifyIORef ref (ResultDeps is <>)
pure vs pure vs
runActions :: Database -> [Action a] -> IO [a] runActions :: Database -> [Action a] -> IO [a]
runActions db xs = do runActions db xs = do
deps <- newIORef mempty deps <- newIORef mempty
runReaderT (fromAction $ parallel xs) $ SAction db deps runReaderT (fromAction $ parallel xs) $ SAction db deps
-- | Returns the set of dirty keys annotated with their age (in # of builds) -- | Returns the set of dirty keys annotated with their age (in # of builds)
getDirtySet :: Action [(Key, Int)] getDirtySet :: Action [(Key, Int)]
getDirtySet = do getDirtySet = do
db <- getDatabase db <- getDatabase
liftIO $ Development.IDE.Graph.Internal.Database.getDirtySet db liftIO $ Development.IDE.Graph.Internal.Database.getDirtySet db
getKeysAndVisitedAge :: Action [(Key, Int)] getKeysAndVisitedAge :: Action [(Key, Int)]
getKeysAndVisitedAge = do getKeysAndVisitedAge = do
db <- getDatabase db <- getDatabase
liftIO $ Development.IDE.Graph.Internal.Database.getKeysAndVisitAge db liftIO $ Development.IDE.Graph.Internal.Database.getKeysAndVisitAge db

116
hls-graph/src/Development/IDE/Graph/Internal/Rules.hs
View File

@ -1,58 +1,58 @@
-- We deliberately want to ensure the function we add to the rule database -- We deliberately want to ensure the function we add to the rule database
-- has the constraints we need on it when we get it out. -- has the constraints we need on it when we get it out.
{-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Development.IDE.Graph.Internal.Rules where module Development.IDE.Graph.Internal.Rules where
import Control.Exception.Extra import Control.Exception.Extra
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Dynamic import Data.Dynamic
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
import Data.IORef import Data.IORef
import Data.Maybe import Data.Maybe
import Data.Typeable import Data.Typeable
import Development.IDE.Graph.Classes import Development.IDE.Graph.Classes
import Development.IDE.Graph.Internal.Types import Development.IDE.Graph.Internal.Types
-- | The type mapping between the @key@ or a rule and the resulting @value@. -- | The type mapping between the @key@ or a rule and the resulting @value@.
-- See 'addBuiltinRule' and 'Development.Shake.Rule.apply'. -- See 'addBuiltinRule' and 'Development.Shake.Rule.apply'.
type family RuleResult key -- = value type family RuleResult key -- = value
action :: Action a -> Rules () action :: Action a -> Rules ()
action x = do action x = do
ref <- Rules $ asks rulesActions ref <- Rules $ asks rulesActions
liftIO $ modifyIORef' ref (void x:) liftIO $ modifyIORef' ref (void x:)
addRule addRule
:: forall key value . :: forall key value .
(RuleResult key ~ value, Typeable key, Hashable key, Eq key, Typeable value) (RuleResult key ~ value, Typeable key, Hashable key, Eq key, Typeable value)
=> (key -> Maybe BS.ByteString -> RunMode -> Action (RunResult value)) => (key -> Maybe BS.ByteString -> RunMode -> Action (RunResult value))
-> Rules () -> Rules ()
addRule f = do addRule f = do
ref <- Rules $ asks rulesMap ref <- Rules $ asks rulesMap
liftIO $ modifyIORef' ref $ Map.insert (typeRep (Proxy :: Proxy key)) (toDyn f2) liftIO $ modifyIORef' ref $ Map.insert (typeRep (Proxy :: Proxy key)) (toDyn f2)
where where
f2 :: Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value) f2 :: Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value)
f2 (Key a) b c = do f2 (Key a) b c = do
v <- f (fromJust $ cast a :: key) b c v <- f (fromJust $ cast a :: key) b c
v <- liftIO $ evaluate v v <- liftIO $ evaluate v
pure $ Value . toDyn <$> v pure $ Value . toDyn <$> v
runRule runRule
:: TheRules -> Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value) :: TheRules -> Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value)
runRule rules key@(Key t) bs mode = case Map.lookup (typeOf t) rules of runRule rules key@(Key t) bs mode = case Map.lookup (typeOf t) rules of
Nothing -> liftIO $ errorIO "Could not find key" Nothing -> liftIO $ errorIO "Could not find key"
Just x -> unwrapDynamic x key bs mode Just x -> unwrapDynamic x key bs mode
runRules :: Dynamic -> Rules () -> IO (TheRules, [Action ()]) runRules :: Dynamic -> Rules () -> IO (TheRules, [Action ()])
runRules rulesExtra (Rules rules) = do runRules rulesExtra (Rules rules) = do
rulesActions <- newIORef [] rulesActions <- newIORef []
rulesMap <- newIORef Map.empty rulesMap <- newIORef Map.empty
runReaderT rules SRules{..} runReaderT rules SRules{..}
(,) <$> readIORef rulesMap <*> readIORef rulesActions (,) <$> readIORef rulesMap <*> readIORef rulesActions

24
hls-graph/src/Paths.hs
View File

@ -1,12 +1,12 @@
-- | Fake cabal module for local building -- | Fake cabal module for local building
module Paths_hls_graph(getDataDir, version) where module Paths_hls_graph(getDataDir, version) where
import Data.Version.Extra import Data.Version.Extra
-- If hls_graph can't find files in the data directory it tries relative to the executable -- If hls_graph can't find files in the data directory it tries relative to the executable
getDataDir :: IO FilePath getDataDir :: IO FilePath
getDataDir = pure "random_path_that_cannot_possibly_exist" getDataDir = pure "random_path_that_cannot_possibly_exist"
version :: Version version :: Version
version = makeVersion [0,0] version = makeVersion [0,0]

1144
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs
View File

File diff suppressed because it is too large Load Diff

40
plugins/hls-eval-plugin/test/info-util/InfoUtil.hs
View File

@ -1,20 +1,20 @@
module InfoUtil module InfoUtil
( Eq ( Eq
, Ord , Ord
, Foo (..) , Foo (..)
, Bar (..) , Bar (..)
, Baz , Baz
) )
where where
import Prelude (Eq, Ord) import Prelude (Eq, Ord)
data Foo = Foo1 | Foo2 data Foo = Foo1 | Foo2
deriving (Eq, Ord) deriving (Eq, Ord)
data Bar = Bar1 | Bar2 | Bar3 data Bar = Bar1 | Bar2 | Bar3
deriving (Eq, Ord) deriving (Eq, Ord)
class Baz t class Baz t
instance Baz Foo instance Baz Foo
instance Baz Bar instance Baz Bar

2
plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs
View File

@ -32,9 +32,9 @@ import Data.Aeson (FromJSON (..),
Value (Null), Value (Null),
genericParseJSON) genericParseJSON)
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BS
import Data.Bifunctor (Bifunctor (first), import Data.Bifunctor (Bifunctor (first),
second) second)
import qualified Data.ByteString as BS
import Data.Coerce import Data.Coerce
import Data.Either (partitionEithers) import Data.Either (partitionEithers)
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM

158
plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs
View File

@ -1,79 +1,79 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Ide.Plugin.StylishHaskell module Ide.Plugin.StylishHaskell
( descriptor ( descriptor
, provider , provider
) )
where where
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Development.IDE hiding (pluginHandlers) import Development.IDE hiding (pluginHandlers)
import Development.IDE.GHC.Compat (ModSummary (ms_hspp_opts), import Development.IDE.GHC.Compat (ModSummary (ms_hspp_opts),
extensionFlags) extensionFlags)
import qualified Development.IDE.GHC.Compat.Util as Util import qualified Development.IDE.GHC.Compat.Util as Util
import GHC.LanguageExtensions.Type import GHC.LanguageExtensions.Type
import Ide.PluginUtils import Ide.PluginUtils
import Ide.Types import Ide.Types
import Language.Haskell.Stylish import Language.Haskell.Stylish
import Language.LSP.Types as J import Language.LSP.Types as J
import System.Directory import System.Directory
import System.FilePath import System.FilePath
descriptor :: PluginId -> PluginDescriptor IdeState descriptor :: PluginId -> PluginDescriptor IdeState
descriptor plId = (defaultPluginDescriptor plId) descriptor plId = (defaultPluginDescriptor plId)
{ pluginHandlers = mkFormattingHandlers provider { pluginHandlers = mkFormattingHandlers provider
} }
-- | Formatter provider of stylish-haskell. -- | Formatter provider of stylish-haskell.
-- Formats the given source in either a given Range or the whole Document. -- Formats the given source in either a given Range or the whole Document.
-- If the provider fails an error is returned that can be displayed to the user. -- If the provider fails an error is returned that can be displayed to the user.
provider :: FormattingHandler IdeState provider :: FormattingHandler IdeState
provider ide typ contents fp _opts = do provider ide typ contents fp _opts = do
dyn <- fmap (ms_hspp_opts . msrModSummary) $ liftIO $ runAction "stylish-haskell" ide $ use_ GetModSummary fp dyn <- fmap (ms_hspp_opts . msrModSummary) $ liftIO $ runAction "stylish-haskell" ide $ use_ GetModSummary fp
let file = fromNormalizedFilePath fp let file = fromNormalizedFilePath fp
config <- liftIO $ loadConfigFrom file config <- liftIO $ loadConfigFrom file
mergedConfig <- liftIO $ getMergedConfig dyn config mergedConfig <- liftIO $ getMergedConfig dyn config
let (range, selectedContents) = case typ of let (range, selectedContents) = case typ of
FormatText -> (fullRange contents, contents) FormatText -> (fullRange contents, contents)
FormatRange r -> (normalize r, extractRange r contents) FormatRange r -> (normalize r, extractRange r contents)
result = runStylishHaskell file mergedConfig selectedContents result = runStylishHaskell file mergedConfig selectedContents
case result of case result of
Left err -> return $ Left $ responseError $ T.pack $ "stylishHaskellCmd: " ++ err Left err -> return $ Left $ responseError $ T.pack $ "stylishHaskellCmd: " ++ err
Right new -> return $ Right $ J.List [TextEdit range new] Right new -> return $ Right $ J.List [TextEdit range new]
where where
getMergedConfig dyn config getMergedConfig dyn config
| null (configLanguageExtensions config) | null (configLanguageExtensions config)
= do = do
logInfo (ideLogger ide) "stylish-haskell uses the language extensions from DynFlags" logInfo (ideLogger ide) "stylish-haskell uses the language extensions from DynFlags"
pure pure
$ config $ config
{ configLanguageExtensions = getExtensions dyn } { configLanguageExtensions = getExtensions dyn }
| otherwise | otherwise
= pure config = pure config
getExtensions = map showExtension . Util.toList . extensionFlags getExtensions = map showExtension . Util.toList . extensionFlags
showExtension Cpp = "CPP" showExtension Cpp = "CPP"
showExtension other = show other showExtension other = show other
-- | Recursively search in every directory of the given filepath for .stylish-haskell.yaml. -- | Recursively search in every directory of the given filepath for .stylish-haskell.yaml.
-- If no such file has been found, return default config. -- If no such file has been found, return default config.
loadConfigFrom :: FilePath -> IO Config loadConfigFrom :: FilePath -> IO Config
loadConfigFrom file = do loadConfigFrom file = do
currDir <- getCurrentDirectory currDir <- getCurrentDirectory
setCurrentDirectory (takeDirectory file) setCurrentDirectory (takeDirectory file)
config <- loadConfig (makeVerbose False) Nothing config <- loadConfig (makeVerbose False) Nothing
setCurrentDirectory currDir setCurrentDirectory currDir
pure config pure config
-- | Run stylish-haskell on the given text with the given configuration. -- | Run stylish-haskell on the given text with the given configuration.
runStylishHaskell :: FilePath -- ^ Location of the file being formatted. Used for error message runStylishHaskell :: FilePath -- ^ Location of the file being formatted. Used for error message
-> Config -- ^ Configuration for stylish-haskell -> Config -- ^ Configuration for stylish-haskell
-> Text -- ^ Text to format -> Text -- ^ Text to format
-> Either String Text -- ^ Either formatted Text or an error message -> Either String Text -- ^ Either formatted Text or an error message
runStylishHaskell file config = fmap fromLines . fmt . toLines runStylishHaskell file config = fmap fromLines . fmt . toLines
where where
fromLines = T.pack . unlines fromLines = T.pack . unlines
fmt = runSteps (configLanguageExtensions config) (Just file) (configSteps config) fmt = runSteps (configLanguageExtensions config) (Just file) (configSteps config)
toLines = lines . T.unpack toLines = lines . T.unpack

1408
shake-bench/src/Development/Benchmark/Rules.hs
View File

File diff suppressed because it is too large Load Diff

302
src/Ide/Arguments.hs
View File

@ -1,151 +1,151 @@
-- Copyright (c) 2019 The DAML Authors. All rights reserved. -- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0 -- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
module Ide.Arguments module Ide.Arguments
( Arguments(..) ( Arguments(..)
, GhcideArguments(..) , GhcideArguments(..)
, PrintVersion(..) , PrintVersion(..)
, BiosAction(..) , BiosAction(..)
, getArguments , getArguments
, haskellLanguageServerVersion , haskellLanguageServerVersion
, haskellLanguageServerNumericVersion , haskellLanguageServerNumericVersion
) where ) where
import Data.Version import Data.Version
import Development.IDE (IdeState) import Development.IDE (IdeState)
import Development.IDE.Main (Command (..), commandP) import Development.IDE.Main (Command (..), commandP)
import GitHash (giHash, tGitInfoCwdTry) import GitHash (giHash, tGitInfoCwdTry)
import Ide.Types (IdePlugins) import Ide.Types (IdePlugins)
import Options.Applicative import Options.Applicative
import Paths_haskell_language_server import Paths_haskell_language_server
import System.Environment import System.Environment
-- --------------------------------------------------------------------- -- ---------------------------------------------------------------------
data Arguments data Arguments
= VersionMode PrintVersion = VersionMode PrintVersion
| ProbeToolsMode | ProbeToolsMode
| ListPluginsMode | ListPluginsMode
| BiosMode BiosAction | BiosMode BiosAction
| Ghcide GhcideArguments | Ghcide GhcideArguments
| VSCodeExtensionSchemaMode | VSCodeExtensionSchemaMode
| DefaultConfigurationMode | DefaultConfigurationMode
data GhcideArguments = GhcideArguments data GhcideArguments = GhcideArguments
{argsCommand :: Command {argsCommand :: Command
,argsCwd :: Maybe FilePath ,argsCwd :: Maybe FilePath
,argsShakeProfiling :: Maybe FilePath ,argsShakeProfiling :: Maybe FilePath
,argsTesting :: Bool ,argsTesting :: Bool
,argsExamplePlugin :: Bool ,argsExamplePlugin :: Bool
-- These next two are for compatibility with existing hie clients, allowing -- These next two are for compatibility with existing hie clients, allowing
-- them to just change the name of the exe and still work. -- them to just change the name of the exe and still work.
, argsDebugOn :: Bool , argsDebugOn :: Bool
, argsLogFile :: Maybe String , argsLogFile :: Maybe String
, argsThreads :: Int , argsThreads :: Int
, argsProjectGhcVersion :: Bool , argsProjectGhcVersion :: Bool
} deriving Show } deriving Show
data PrintVersion data PrintVersion
= PrintVersion = PrintVersion
| PrintNumericVersion | PrintNumericVersion
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
data BiosAction data BiosAction
= PrintCradleType = PrintCradleType
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
getArguments :: String -> IdePlugins IdeState -> IO Arguments getArguments :: String -> IdePlugins IdeState -> IO Arguments
getArguments exeName plugins = execParser opts getArguments exeName plugins = execParser opts
where where
opts = info (( opts = info ((
VersionMode <$> printVersionParser exeName VersionMode <$> printVersionParser exeName
<|> probeToolsParser exeName <|> probeToolsParser exeName
<|> listPluginsParser <|> listPluginsParser
<|> BiosMode <$> biosParser <|> BiosMode <$> biosParser
<|> Ghcide <$> arguments plugins <|> Ghcide <$> arguments plugins
) )
<**> helper) <**> helper)
( fullDesc ( fullDesc
<> progDesc "Used as a test bed to check your IDE Client will work" <> progDesc "Used as a test bed to check your IDE Client will work"
<> header (exeName ++ " - GHC Haskell LSP server")) <> header (exeName ++ " - GHC Haskell LSP server"))
printVersionParser :: String -> Parser PrintVersion printVersionParser :: String -> Parser PrintVersion
printVersionParser exeName = printVersionParser exeName =
flag' PrintVersion flag' PrintVersion
(long "version" <> help ("Show " ++ exeName ++ " and GHC versions")) (long "version" <> help ("Show " ++ exeName ++ " and GHC versions"))
<|> <|>
flag' PrintNumericVersion flag' PrintNumericVersion
(long "numeric-version" <> help ("Show numeric version of " ++ exeName)) (long "numeric-version" <> help ("Show numeric version of " ++ exeName))
biosParser :: Parser BiosAction biosParser :: Parser BiosAction
biosParser = biosParser =
flag' PrintCradleType flag' PrintCradleType
(long "print-cradle" <> help "Print the project cradle type") (long "print-cradle" <> help "Print the project cradle type")
probeToolsParser :: String -> Parser Arguments probeToolsParser :: String -> Parser Arguments
probeToolsParser exeName = probeToolsParser exeName =
flag' ProbeToolsMode flag' ProbeToolsMode
(long "probe-tools" <> help ("Show " ++ exeName ++ " version and other tools of interest")) (long "probe-tools" <> help ("Show " ++ exeName ++ " version and other tools of interest"))
listPluginsParser :: Parser Arguments listPluginsParser :: Parser Arguments
listPluginsParser = listPluginsParser =
flag' ListPluginsMode flag' ListPluginsMode
(long "list-plugins" <> help "List all available plugins") (long "list-plugins" <> help "List all available plugins")
arguments :: IdePlugins IdeState -> Parser GhcideArguments arguments :: IdePlugins IdeState -> Parser GhcideArguments
arguments plugins = GhcideArguments arguments plugins = GhcideArguments
<$> (commandP plugins <|> lspCommand <|> checkCommand) <$> (commandP plugins <|> lspCommand <|> checkCommand)
<*> optional (strOption $ long "cwd" <> metavar "DIR" <*> optional (strOption $ long "cwd" <> metavar "DIR"
<> help "Change to this directory") <> help "Change to this directory")
<*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <*> optional (strOption $ long "shake-profiling" <> metavar "DIR"
<> help "Dump profiling reports to this directory") <> help "Dump profiling reports to this directory")
<*> switch (long "test" <*> switch (long "test"
<> help "Enable additional lsp messages used by the testsuite") <> help "Enable additional lsp messages used by the testsuite")
<*> switch (long "example" <*> switch (long "example"
<> help "Include the Example Plugin. For Plugin devs only") <> help "Include the Example Plugin. For Plugin devs only")
<*> switch <*> switch
( long "debug" ( long "debug"
<> short 'd' <> short 'd'
<> help "Generate debug output" <> help "Generate debug output"
) )
<*> optional (strOption <*> optional (strOption
( long "logfile" ( long "logfile"
<> short 'l' <> short 'l'
<> metavar "LOGFILE" <> metavar "LOGFILE"
<> help "File to log to, defaults to stdout" <> help "File to log to, defaults to stdout"
)) ))
<*> option auto <*> option auto
(short 'j' (short 'j'
<> help "Number of threads (0: automatic)" <> help "Number of threads (0: automatic)"
<> metavar "NUM" <> metavar "NUM"
<> value 0 <> value 0
<> showDefault <> showDefault
) )
<*> switch (long "project-ghc-version" <*> switch (long "project-ghc-version"
<> help "Work out the project GHC version and print it") <> help "Work out the project GHC version and print it")
where where
lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP server") lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP server")
checkCommand = Check <$> many (argument str (metavar "FILES/DIRS...")) checkCommand = Check <$> many (argument str (metavar "FILES/DIRS..."))
-- --------------------------------------------------------------------- -- ---------------------------------------------------------------------
haskellLanguageServerNumericVersion :: String haskellLanguageServerNumericVersion :: String
haskellLanguageServerNumericVersion = showVersion version haskellLanguageServerNumericVersion = showVersion version
haskellLanguageServerVersion :: IO String haskellLanguageServerVersion :: IO String
haskellLanguageServerVersion = do haskellLanguageServerVersion = do
path <- getExecutablePath path <- getExecutablePath
let gi = $$tGitInfoCwdTry let gi = $$tGitInfoCwdTry
gitHashSection = case gi of gitHashSection = case gi of
Right gi -> " (GIT hash: " <> giHash gi <> ")" Right gi -> " (GIT hash: " <> giHash gi <> ")"
Left _ -> "" Left _ -> ""
return $ "haskell-language-server version: " <> haskellLanguageServerNumericVersion return $ "haskell-language-server version: " <> haskellLanguageServerNumericVersion
<> " (GHC: " <> VERSION_ghc <> " (GHC: " <> VERSION_ghc
<> ") (PATH: " <> path <> ")" <> ") (PATH: " <> path <> ")"
<> gitHashSection <> gitHashSection

164
src/Ide/Version.hs
View File

@ -1,82 +1,82 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
-- | Information and display strings for HIE's version -- | Information and display strings for HIE's version
-- and the current project's version -- and the current project's version
module Ide.Version where module Ide.Version where
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
import Data.Version import Data.Version
import GitHash (giCommitCount, tGitInfoCwdTry) import GitHash (giCommitCount, tGitInfoCwdTry)
import Options.Applicative.Simple (simpleVersion) import Options.Applicative.Simple (simpleVersion)
import qualified Paths_haskell_language_server as Meta import qualified Paths_haskell_language_server as Meta
import System.Directory import System.Directory
import System.Exit import System.Exit
import System.Info import System.Info
import System.Process import System.Process
import Text.ParserCombinators.ReadP import Text.ParserCombinators.ReadP
-- >>> hlsVersion -- >>> hlsVersion
hlsVersion :: String hlsVersion :: String
hlsVersion = hlsVersion =
let gi = $$tGitInfoCwdTry let gi = $$tGitInfoCwdTry
commitCount = case gi of commitCount = case gi of
Right gi -> show $ giCommitCount gi Right gi -> show $ giCommitCount gi
Left _ -> "UNKNOWN" Left _ -> "UNKNOWN"
in concat $ concat in concat $ concat
[ [$(simpleVersion Meta.version)] [ [$(simpleVersion Meta.version)]
-- Leave out number of commits for --depth=1 clone -- Leave out number of commits for --depth=1 clone
-- See https://github.com/commercialhaskell/stack/issues/792 -- See https://github.com/commercialhaskell/stack/issues/792
, [" (" ++ commitCount ++ " commits)" | commitCount /= ("1"::String) && , [" (" ++ commitCount ++ " commits)" | commitCount /= ("1"::String) &&
commitCount /= ("UNKNOWN" :: String)] commitCount /= ("UNKNOWN" :: String)]
, [" ", arch] , [" ", arch]
, [" ", hlsGhcDisplayVersion] , [" ", hlsGhcDisplayVersion]
] ]
where where
hlsGhcDisplayVersion = compilerName ++ "-" ++ VERSION_ghc hlsGhcDisplayVersion = compilerName ++ "-" ++ VERSION_ghc
data ProgramsOfInterest = ProgramsOfInterest data ProgramsOfInterest = ProgramsOfInterest
{ cabalVersion :: Maybe Version { cabalVersion :: Maybe Version
, stackVersion :: Maybe Version , stackVersion :: Maybe Version
, ghcVersion :: Maybe Version , ghcVersion :: Maybe Version
} }
showProgramVersionOfInterest :: ProgramsOfInterest -> String showProgramVersionOfInterest :: ProgramsOfInterest -> String
showProgramVersionOfInterest ProgramsOfInterest {..} = showProgramVersionOfInterest ProgramsOfInterest {..} =
unlines unlines
[ "cabal:\t\t" ++ showVersionWithDefault cabalVersion [ "cabal:\t\t" ++ showVersionWithDefault cabalVersion
, "stack:\t\t" ++ showVersionWithDefault stackVersion , "stack:\t\t" ++ showVersionWithDefault stackVersion
, "ghc:\t\t" ++ showVersionWithDefault ghcVersion , "ghc:\t\t" ++ showVersionWithDefault ghcVersion
] ]
where where
showVersionWithDefault :: Maybe Version -> String showVersionWithDefault :: Maybe Version -> String
showVersionWithDefault = maybe "Not found" showVersion showVersionWithDefault = maybe "Not found" showVersion
findProgramVersions :: IO ProgramsOfInterest findProgramVersions :: IO ProgramsOfInterest
findProgramVersions = ProgramsOfInterest findProgramVersions = ProgramsOfInterest
<$> findVersionOf "cabal" <$> findVersionOf "cabal"
<*> findVersionOf "stack" <*> findVersionOf "stack"
<*> findVersionOf "ghc" <*> findVersionOf "ghc"
-- | Find the version of the given program. -- | Find the version of the given program.
-- Assumes the program accepts the cli argument "--numeric-version". -- Assumes the program accepts the cli argument "--numeric-version".
-- If the invocation has a non-zero exit-code, we return 'Nothing' -- If the invocation has a non-zero exit-code, we return 'Nothing'
findVersionOf :: FilePath -> IO (Maybe Version) findVersionOf :: FilePath -> IO (Maybe Version)
findVersionOf tool = findVersionOf tool =
findExecutable tool >>= \case findExecutable tool >>= \case
Nothing -> pure Nothing Nothing -> pure Nothing
Just path -> Just path ->
readProcessWithExitCode path ["--numeric-version"] "" >>= \case readProcessWithExitCode path ["--numeric-version"] "" >>= \case
(ExitSuccess, sout, _) -> pure $ consumeParser myVersionParser sout (ExitSuccess, sout, _) -> pure $ consumeParser myVersionParser sout
_ -> pure Nothing _ -> pure Nothing
where where
myVersionParser = do myVersionParser = do
skipSpaces skipSpaces
version <- parseVersion version <- parseVersion
skipSpaces skipSpaces
pure version pure version
consumeParser :: ReadP a -> String -> Maybe a consumeParser :: ReadP a -> String -> Maybe a
consumeParser p input = listToMaybe $ map fst . filter (null . snd) $ readP_to_S p input consumeParser p input = listToMaybe $ map fst . filter (null . snd) $ readP_to_S p input