mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-11 16:56:14 +03:00
Add pre-commit hook for cleaning up mixed-line endings (#2679)
* 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:
parent
9faa179017
commit
411db02883
2
.gitignore
vendored
2
.gitignore
vendored
@ -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
32
.pre-commit-config.yaml
Normal 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$"
|
||||||
|
}
|
||||||
|
]
|
||||||
|
}
|
||||||
|
]
|
||||||
|
}
|
@ -53,7 +53,7 @@ steps:
|
|||||||
|
|
||||||
columns: 80
|
columns: 80
|
||||||
|
|
||||||
newline: native
|
newline: lf
|
||||||
|
|
||||||
language_extensions:
|
language_extensions:
|
||||||
- BangPatterns
|
- BangPatterns
|
||||||
|
@ -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$"
|
||||||
|
}
|
||||||
|
]
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
|
||||||
|
@ -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)
|
||||||
|
@ -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
478
hls-graph/html/ts/jquery.flot.d.ts
vendored
@ -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;
|
||||||
}
|
}
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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]
|
||||||
|
File diff suppressed because it is too large
Load Diff
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
File diff suppressed because it is too large
Load Diff
@ -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
|
||||||
|
@ -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
|
||||||
|
Loading…
Reference in New Issue
Block a user