mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-08-17 04:20:37 +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:
Nick Suchecki
GitHub
parent
9faa179017
commit
411db02883
2
.gitignore
vendored
2
.gitignore
vendored
@ -32,7 +32,7 @@ test/testdata/**/hie.yaml
|
||||
.shake/
|
||||
|
||||
# pre-commit-hook.nix
|
||||
.pre-commit-config.yaml
|
||||
#.pre-commit-config.yaml
|
||||
|
||||
# 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
|
||||
|
||||
newline: native
|
||||
newline: lf
|
||||
|
||||
language_extensions:
|
||||
- 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": "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 GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module Development.IDE.Core.UseStale
|
||||
( Age(..)
|
||||
, Tracked
|
||||
, unTrack
|
||||
, PositionMap
|
||||
, TrackedStale (..)
|
||||
, untrackedStaleValue
|
||||
, unsafeMkStale
|
||||
, unsafeMkCurrent
|
||||
, unsafeCopyAge
|
||||
, MapAge (..)
|
||||
, dualPositionMap
|
||||
, useWithStale
|
||||
, useWithStale_
|
||||
) where
|
||||
|
||||
import Control.Arrow
|
||||
import Control.Category (Category)
|
||||
import qualified Control.Category as C
|
||||
import Control.DeepSeq (NFData)
|
||||
import Data.Aeson
|
||||
import Data.Coerce (coerce)
|
||||
import Data.Functor ((<&>))
|
||||
import Data.Functor.Identity (Identity (Identity))
|
||||
import Data.Kind (Type)
|
||||
import Data.String (fromString)
|
||||
import Development.IDE (Action, IdeRule,
|
||||
NormalizedFilePath,
|
||||
Range,
|
||||
rangeToRealSrcSpan,
|
||||
realSrcSpanToRange)
|
||||
import qualified Development.IDE.Core.PositionMapping as P
|
||||
import qualified Development.IDE.Core.Shake as IDE
|
||||
import Development.IDE.GHC.Compat (RealSrcSpan, srcSpanFile)
|
||||
import Development.IDE.GHC.Compat.Util (unpackFS)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A data kind for 'Tracked'.
|
||||
data Age = Current | Stale Type
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | 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
|
||||
-- to ensure they can't be unified.
|
||||
newtype Tracked (age :: Age) a = UnsafeTracked
|
||||
{ unTrack :: a
|
||||
}
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON, NFData)
|
||||
deriving (Applicative, Monad) via Identity
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Like 'P.PositionMapping', but with annotated ages for how 'Tracked' values
|
||||
-- change. Use the 'Category' instance to compose 'PositionMapping's in order
|
||||
-- to transform between values of different stale ages.
|
||||
newtype PositionMap (from :: Age) (to :: Age) = PositionMap
|
||||
{ _getPositionMapping :: P.PositionMapping
|
||||
}
|
||||
|
||||
instance Category PositionMap where
|
||||
id = coerce P.zeroMapping
|
||||
(.) = coerce P.composeDelta
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Get a 'PositionMap' that runs in the opposite direction.
|
||||
dualPositionMap :: PositionMap from to -> PositionMap to from
|
||||
dualPositionMap (PositionMap (P.PositionMapping (P.PositionDelta from to))) =
|
||||
PositionMap $ P.PositionMapping $ P.PositionDelta to from
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A pair containing a @'Tracked' 'Stale'@ value, as well as
|
||||
-- a 'PositionMapping' that will fast-forward values to the current age.
|
||||
data TrackedStale a where
|
||||
TrackedStale
|
||||
:: Tracked (Stale s) a
|
||||
-> PositionMap (Stale s) Current
|
||||
-> TrackedStale a
|
||||
|
||||
instance Functor TrackedStale where
|
||||
fmap f (TrackedStale t pm) = TrackedStale (fmap f t) pm
|
||||
|
||||
|
||||
untrackedStaleValue :: TrackedStale a -> a
|
||||
untrackedStaleValue (TrackedStale ta _) = coerce ta
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A class for which 'Tracked' values can be run across a 'PositionMapping'
|
||||
-- to change their ages.
|
||||
class MapAge a where
|
||||
{-# MINIMAL mapAgeFrom | mapAgeTo #-}
|
||||
mapAgeFrom :: PositionMap from to -> Tracked to a -> Maybe (Tracked from a)
|
||||
mapAgeFrom = mapAgeTo . dualPositionMap
|
||||
|
||||
mapAgeTo :: PositionMap from to -> Tracked from a -> Maybe (Tracked to a)
|
||||
mapAgeTo = mapAgeFrom . dualPositionMap
|
||||
|
||||
|
||||
instance MapAge Range where
|
||||
mapAgeFrom = coerce P.fromCurrentRange
|
||||
mapAgeTo = coerce P.toCurrentRange
|
||||
|
||||
|
||||
instance MapAge RealSrcSpan where
|
||||
mapAgeFrom =
|
||||
invMapAge (\fs -> rangeToRealSrcSpan (fromString $ unpackFS fs))
|
||||
(srcSpanFile &&& realSrcSpanToRange)
|
||||
. mapAgeFrom
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Helper function for deriving 'MapAge' for values in terms of other
|
||||
-- instances.
|
||||
invMapAge
|
||||
:: (c -> a -> b)
|
||||
-> (b -> (c, a))
|
||||
-> (Tracked from a -> Maybe (Tracked to a))
|
||||
-> Tracked from b
|
||||
-> Maybe (Tracked to b)
|
||||
invMapAge to from f t =
|
||||
let (c, t') = unTrack $ fmap from t
|
||||
in fmap (fmap $ to c) $ f $ UnsafeTracked t'
|
||||
|
||||
|
||||
unsafeMkCurrent :: age -> Tracked 'Current age
|
||||
unsafeMkCurrent = coerce
|
||||
|
||||
|
||||
unsafeMkStale :: age -> Tracked (Stale s) age
|
||||
unsafeMkStale = coerce
|
||||
|
||||
|
||||
unsafeCopyAge :: Tracked age a -> b -> Tracked age b
|
||||
unsafeCopyAge _ = coerce
|
||||
|
||||
|
||||
-- | Request a Rule result, it not available return the last computed result, if any, which may be stale
|
||||
useWithStale :: IdeRule k v
|
||||
=> k -> NormalizedFilePath -> Action (Maybe (TrackedStale v))
|
||||
useWithStale key file = do
|
||||
x <- IDE.useWithStale key file
|
||||
pure $ x <&> \(v, pm) ->
|
||||
TrackedStale (coerce v) (coerce pm)
|
||||
|
||||
-- | Request a Rule result, it not available return the last computed result which may be stale.
|
||||
-- Errors out if none available.
|
||||
useWithStale_ :: IdeRule k v
|
||||
=> k -> NormalizedFilePath -> Action (TrackedStale v)
|
||||
useWithStale_ key file = do
|
||||
(v, pm) <- IDE.useWithStale_ key file
|
||||
pure $ TrackedStale (coerce v) (coerce pm)
|
||||
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module Development.IDE.Core.UseStale
|
||||
( Age(..)
|
||||
, Tracked
|
||||
, unTrack
|
||||
, PositionMap
|
||||
, TrackedStale (..)
|
||||
, untrackedStaleValue
|
||||
, unsafeMkStale
|
||||
, unsafeMkCurrent
|
||||
, unsafeCopyAge
|
||||
, MapAge (..)
|
||||
, dualPositionMap
|
||||
, useWithStale
|
||||
, useWithStale_
|
||||
) where
|
||||
|
||||
import Control.Arrow
|
||||
import Control.Category (Category)
|
||||
import qualified Control.Category as C
|
||||
import Control.DeepSeq (NFData)
|
||||
import Data.Aeson
|
||||
import Data.Coerce (coerce)
|
||||
import Data.Functor ((<&>))
|
||||
import Data.Functor.Identity (Identity (Identity))
|
||||
import Data.Kind (Type)
|
||||
import Data.String (fromString)
|
||||
import Development.IDE (Action, IdeRule,
|
||||
NormalizedFilePath,
|
||||
Range,
|
||||
rangeToRealSrcSpan,
|
||||
realSrcSpanToRange)
|
||||
import qualified Development.IDE.Core.PositionMapping as P
|
||||
import qualified Development.IDE.Core.Shake as IDE
|
||||
import Development.IDE.GHC.Compat (RealSrcSpan, srcSpanFile)
|
||||
import Development.IDE.GHC.Compat.Util (unpackFS)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A data kind for 'Tracked'.
|
||||
data Age = Current | Stale Type
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | 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
|
||||
-- to ensure they can't be unified.
|
||||
newtype Tracked (age :: Age) a = UnsafeTracked
|
||||
{ unTrack :: a
|
||||
}
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON, NFData)
|
||||
deriving (Applicative, Monad) via Identity
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Like 'P.PositionMapping', but with annotated ages for how 'Tracked' values
|
||||
-- change. Use the 'Category' instance to compose 'PositionMapping's in order
|
||||
-- to transform between values of different stale ages.
|
||||
newtype PositionMap (from :: Age) (to :: Age) = PositionMap
|
||||
{ _getPositionMapping :: P.PositionMapping
|
||||
}
|
||||
|
||||
instance Category PositionMap where
|
||||
id = coerce P.zeroMapping
|
||||
(.) = coerce P.composeDelta
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Get a 'PositionMap' that runs in the opposite direction.
|
||||
dualPositionMap :: PositionMap from to -> PositionMap to from
|
||||
dualPositionMap (PositionMap (P.PositionMapping (P.PositionDelta from to))) =
|
||||
PositionMap $ P.PositionMapping $ P.PositionDelta to from
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A pair containing a @'Tracked' 'Stale'@ value, as well as
|
||||
-- a 'PositionMapping' that will fast-forward values to the current age.
|
||||
data TrackedStale a where
|
||||
TrackedStale
|
||||
:: Tracked (Stale s) a
|
||||
-> PositionMap (Stale s) Current
|
||||
-> TrackedStale a
|
||||
|
||||
instance Functor TrackedStale where
|
||||
fmap f (TrackedStale t pm) = TrackedStale (fmap f t) pm
|
||||
|
||||
|
||||
untrackedStaleValue :: TrackedStale a -> a
|
||||
untrackedStaleValue (TrackedStale ta _) = coerce ta
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A class for which 'Tracked' values can be run across a 'PositionMapping'
|
||||
-- to change their ages.
|
||||
class MapAge a where
|
||||
{-# MINIMAL mapAgeFrom | mapAgeTo #-}
|
||||
mapAgeFrom :: PositionMap from to -> Tracked to a -> Maybe (Tracked from a)
|
||||
mapAgeFrom = mapAgeTo . dualPositionMap
|
||||
|
||||
mapAgeTo :: PositionMap from to -> Tracked from a -> Maybe (Tracked to a)
|
||||
mapAgeTo = mapAgeFrom . dualPositionMap
|
||||
|
||||
|
||||
instance MapAge Range where
|
||||
mapAgeFrom = coerce P.fromCurrentRange
|
||||
mapAgeTo = coerce P.toCurrentRange
|
||||
|
||||
|
||||
instance MapAge RealSrcSpan where
|
||||
mapAgeFrom =
|
||||
invMapAge (\fs -> rangeToRealSrcSpan (fromString $ unpackFS fs))
|
||||
(srcSpanFile &&& realSrcSpanToRange)
|
||||
. mapAgeFrom
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Helper function for deriving 'MapAge' for values in terms of other
|
||||
-- instances.
|
||||
invMapAge
|
||||
:: (c -> a -> b)
|
||||
-> (b -> (c, a))
|
||||
-> (Tracked from a -> Maybe (Tracked to a))
|
||||
-> Tracked from b
|
||||
-> Maybe (Tracked to b)
|
||||
invMapAge to from f t =
|
||||
let (c, t') = unTrack $ fmap from t
|
||||
in fmap (fmap $ to c) $ f $ UnsafeTracked t'
|
||||
|
||||
|
||||
unsafeMkCurrent :: age -> Tracked 'Current age
|
||||
unsafeMkCurrent = coerce
|
||||
|
||||
|
||||
unsafeMkStale :: age -> Tracked (Stale s) age
|
||||
unsafeMkStale = coerce
|
||||
|
||||
|
||||
unsafeCopyAge :: Tracked age a -> b -> Tracked age b
|
||||
unsafeCopyAge _ = coerce
|
||||
|
||||
|
||||
-- | Request a Rule result, it not available return the last computed result, if any, which may be stale
|
||||
useWithStale :: IdeRule k v
|
||||
=> k -> NormalizedFilePath -> Action (Maybe (TrackedStale v))
|
||||
useWithStale key file = do
|
||||
x <- IDE.useWithStale key file
|
||||
pure $ x <&> \(v, pm) ->
|
||||
TrackedStale (coerce v) (coerce pm)
|
||||
|
||||
-- | Request a Rule result, it not available return the last computed result which may be stale.
|
||||
-- Errors out if none available.
|
||||
useWithStale_ :: IdeRule k v
|
||||
=> k -> NormalizedFilePath -> Action (TrackedStale v)
|
||||
useWithStale_ key file = do
|
||||
(v, pm) <- IDE.useWithStale_ key file
|
||||
pure $ TrackedStale (coerce v) (coerce pm)
|
||||
|
||||
|
||||
@ -1,63 +1,63 @@
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE NondecreasingIndentation #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
--
|
||||
-- GHC Driver
|
||||
--
|
||||
-- (c) The University of Glasgow 2005
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Development.IDE.GHC.CPP(doCpp, addOptP)
|
||||
where
|
||||
|
||||
import Development.IDE.GHC.Compat as Compat
|
||||
import GHC
|
||||
#if !MIN_VERSION_ghc(8,10,0)
|
||||
import qualified Development.IDE.GHC.Compat.CPP as CPP
|
||||
#else
|
||||
import Development.IDE.GHC.Compat.Util
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
import qualified GHC.Driver.Pipeline as Pipeline
|
||||
import GHC.Settings
|
||||
#else
|
||||
#if MIN_VERSION_ghc (8,10,0)
|
||||
import qualified DriverPipeline as Pipeline
|
||||
import ToolSettings
|
||||
#else
|
||||
import DynFlags
|
||||
#endif
|
||||
#endif
|
||||
|
||||
addOptP :: String -> DynFlags -> DynFlags
|
||||
#if MIN_VERSION_ghc (8,10,0)
|
||||
addOptP f = alterToolSettings $ \s -> s
|
||||
{ toolSettings_opt_P = f : toolSettings_opt_P s
|
||||
, toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)
|
||||
}
|
||||
where
|
||||
fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss
|
||||
alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }
|
||||
#else
|
||||
addOptP opt = onSettings (onOptP (opt:))
|
||||
where
|
||||
onSettings f x = x{settings = f $ settings x}
|
||||
onOptP f x = x{sOpt_P = f $ sOpt_P x}
|
||||
#endif
|
||||
|
||||
doCpp :: HscEnv -> Bool -> FilePath -> FilePath -> IO ()
|
||||
doCpp env raw input_fn output_fn =
|
||||
#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
|
||||
#elif MIN_VERSION_ghc (8,10,0)
|
||||
Pipeline.doCpp (hsc_dflags env) raw input_fn output_fn
|
||||
#else
|
||||
CPP.doCpp (hsc_dflags env) raw input_fn output_fn
|
||||
#endif
|
||||
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE NondecreasingIndentation #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
--
|
||||
-- GHC Driver
|
||||
--
|
||||
-- (c) The University of Glasgow 2005
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Development.IDE.GHC.CPP(doCpp, addOptP)
|
||||
where
|
||||
|
||||
import Development.IDE.GHC.Compat as Compat
|
||||
import GHC
|
||||
#if !MIN_VERSION_ghc(8,10,0)
|
||||
import qualified Development.IDE.GHC.Compat.CPP as CPP
|
||||
#else
|
||||
import Development.IDE.GHC.Compat.Util
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
import qualified GHC.Driver.Pipeline as Pipeline
|
||||
import GHC.Settings
|
||||
#else
|
||||
#if MIN_VERSION_ghc (8,10,0)
|
||||
import qualified DriverPipeline as Pipeline
|
||||
import ToolSettings
|
||||
#else
|
||||
import DynFlags
|
||||
#endif
|
||||
#endif
|
||||
|
||||
addOptP :: String -> DynFlags -> DynFlags
|
||||
#if MIN_VERSION_ghc (8,10,0)
|
||||
addOptP f = alterToolSettings $ \s -> s
|
||||
{ toolSettings_opt_P = f : toolSettings_opt_P s
|
||||
, toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)
|
||||
}
|
||||
where
|
||||
fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss
|
||||
alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }
|
||||
#else
|
||||
addOptP opt = onSettings (onOptP (opt:))
|
||||
where
|
||||
onSettings f x = x{settings = f $ settings x}
|
||||
onOptP f x = x{sOpt_P = f $ sOpt_P x}
|
||||
#endif
|
||||
|
||||
doCpp :: HscEnv -> Bool -> FilePath -> FilePath -> IO ()
|
||||
doCpp env raw input_fn output_fn =
|
||||
#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
|
||||
#elif MIN_VERSION_ghc (8,10,0)
|
||||
Pipeline.doCpp (hsc_dflags env) raw input_fn output_fn
|
||||
#else
|
||||
CPP.doCpp (hsc_dflags env) raw input_fn output_fn
|
||||
#endif
|
||||
|
||||
|
||||
@ -1,204 +1,204 @@
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
-- 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.
|
||||
-- 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
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
|
||||
-- | Re-export 'doCpp' for GHC < 8.10.
|
||||
--
|
||||
-- Later versions export what we need.
|
||||
module Development.IDE.GHC.Compat.CPP (
|
||||
doCpp
|
||||
) where
|
||||
|
||||
import FileCleanup
|
||||
import Packages
|
||||
import Panic
|
||||
import SysTools
|
||||
#if MIN_VERSION_ghc(8,8,2)
|
||||
import LlvmCodeGen (llvmVersionList)
|
||||
#elif MIN_VERSION_ghc(8,8,0)
|
||||
import LlvmCodeGen (LlvmVersion (..))
|
||||
#endif
|
||||
import Control.Monad
|
||||
import Data.List (intercalate)
|
||||
import Data.Maybe
|
||||
import Data.Version
|
||||
import DynFlags
|
||||
import Module (rtsUnitId, toInstalledUnitId)
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.Info
|
||||
|
||||
import Development.IDE.GHC.Compat as Compat
|
||||
|
||||
doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
|
||||
doCpp dflags raw input_fn output_fn = do
|
||||
let hscpp_opts = picPOpts dflags
|
||||
let cmdline_include_paths = includePaths dflags
|
||||
|
||||
pkg_include_dirs <- getPackageIncludePath dflags []
|
||||
let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
|
||||
(includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
|
||||
let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
|
||||
(includePathsQuote cmdline_include_paths)
|
||||
let include_paths = include_paths_quote ++ include_paths_global
|
||||
|
||||
let verbFlags = getVerbFlags dflags
|
||||
|
||||
let cpp_prog args | raw = SysTools.runCpp dflags args
|
||||
#if MIN_VERSION_ghc(8,10,0)
|
||||
| otherwise = SysTools.runCc Nothing
|
||||
#else
|
||||
| otherwise = SysTools.runCc
|
||||
#endif
|
||||
dflags (SysTools.Option "-E" : args)
|
||||
|
||||
let target_defs =
|
||||
-- NEIL: Patched to use System.Info instead of constants from CPP
|
||||
[ "-D" ++ os ++ "_BUILD_OS",
|
||||
"-D" ++ arch ++ "_BUILD_ARCH",
|
||||
"-D" ++ os ++ "_HOST_OS",
|
||||
"-D" ++ arch ++ "_HOST_ARCH" ]
|
||||
-- remember, in code we *compile*, the HOST is the same our TARGET,
|
||||
-- and BUILD is the same as our HOST.
|
||||
|
||||
let sse_defs =
|
||||
[ "-D__SSE__" | isSseEnabled dflags ] ++
|
||||
[ "-D__SSE2__" | isSse2Enabled dflags ] ++
|
||||
[ "-D__SSE4_2__" | isSse4_2Enabled dflags ]
|
||||
|
||||
let avx_defs =
|
||||
[ "-D__AVX__" | isAvxEnabled dflags ] ++
|
||||
[ "-D__AVX2__" | isAvx2Enabled dflags ] ++
|
||||
[ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
|
||||
[ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
|
||||
[ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++
|
||||
[ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
|
||||
|
||||
backend_defs <- getBackendDefs dflags
|
||||
|
||||
let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
|
||||
-- Default CPP defines in Haskell source
|
||||
ghcVersionH <- getGhcVersionPathName dflags
|
||||
let hsSourceCppOpts = [ "-include", ghcVersionH ]
|
||||
|
||||
-- MIN_VERSION macros
|
||||
let uids = explicitPackages (pkgState dflags)
|
||||
pkgs = catMaybes (map (lookupPackage dflags) uids)
|
||||
mb_macro_include <-
|
||||
if not (null pkgs) && gopt Opt_VersionMacros dflags
|
||||
then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
|
||||
writeFile macro_stub (generatePackageVersionMacros pkgs)
|
||||
-- Include version macros for every *exposed* package.
|
||||
-- Without -hide-all-packages and with a package database
|
||||
-- size of 1000 packages, it takes cpp an estimated 2
|
||||
-- milliseconds to process this file. See #10970
|
||||
-- comment 8.
|
||||
return [SysTools.FileOption "-include" macro_stub]
|
||||
else return []
|
||||
|
||||
cpp_prog ( map SysTools.Option verbFlags
|
||||
++ map SysTools.Option include_paths
|
||||
++ map SysTools.Option hsSourceCppOpts
|
||||
++ map SysTools.Option target_defs
|
||||
++ map SysTools.Option backend_defs
|
||||
++ map SysTools.Option th_defs
|
||||
++ map SysTools.Option hscpp_opts
|
||||
++ map SysTools.Option sse_defs
|
||||
++ map SysTools.Option avx_defs
|
||||
++ mb_macro_include
|
||||
-- Set the language mode to assembler-with-cpp when preprocessing. This
|
||||
-- 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
|
||||
-- about this.
|
||||
++ [ SysTools.Option "-x"
|
||||
, SysTools.Option "assembler-with-cpp"
|
||||
, SysTools.Option input_fn
|
||||
-- We hackily use Option instead of FileOption here, so that the file
|
||||
-- name is not back-slashed on Windows. cpp is capable of
|
||||
-- dealing with / in filenames, so it works fine. Furthermore
|
||||
-- if we put in backslashes, cpp outputs #line directives
|
||||
-- with *double* backslashes. And that in turn means that
|
||||
-- our error messages get double backslashes in them.
|
||||
-- In due course we should arrange that the lexer deals
|
||||
-- with these \\ escapes properly.
|
||||
, SysTools.Option "-o"
|
||||
, SysTools.FileOption "" output_fn
|
||||
])
|
||||
|
||||
getBackendDefs :: DynFlags -> IO [String]
|
||||
getBackendDefs dflags | hscTarget dflags == HscLlvm = do
|
||||
llvmVer <- figureLlvmVersion dflags
|
||||
return $ case llvmVer of
|
||||
#if MIN_VERSION_ghc(8,8,2)
|
||||
Just v
|
||||
| [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ]
|
||||
| m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ]
|
||||
#elif MIN_VERSION_ghc(8,8,0)
|
||||
Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]
|
||||
Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
|
||||
#else
|
||||
Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]
|
||||
#endif
|
||||
_ -> []
|
||||
where
|
||||
format (major, minor)
|
||||
| minor >= 100 = error "getBackendDefs: Unsupported minor version"
|
||||
| otherwise = show $ (100 * major + minor :: Int) -- Contract is Int
|
||||
|
||||
getBackendDefs _ =
|
||||
return []
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Macros (cribbed from Cabal)
|
||||
|
||||
generatePackageVersionMacros :: [Compat.UnitInfo] -> String
|
||||
generatePackageVersionMacros pkgs = concat
|
||||
-- Do not add any C-style comments. See #3389.
|
||||
[ generateMacros "" pkgname version
|
||||
| pkg <- pkgs
|
||||
, let version = packageVersion pkg
|
||||
pkgname = map fixchar (packageNameString pkg)
|
||||
]
|
||||
|
||||
fixchar :: Char -> Char
|
||||
fixchar '-' = '_'
|
||||
fixchar c = c
|
||||
|
||||
generateMacros :: String -> String -> Version -> String
|
||||
generateMacros prefix name version =
|
||||
concat
|
||||
["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
|
||||
,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
|
||||
," (major1) < ",major1," || \\\n"
|
||||
," (major1) == ",major1," && (major2) < ",major2," || \\\n"
|
||||
," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
|
||||
,"\n\n"
|
||||
]
|
||||
where
|
||||
(major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
|
||||
|
||||
|
||||
-- | Find out path to @ghcversion.h@ file
|
||||
getGhcVersionPathName :: DynFlags -> IO FilePath
|
||||
getGhcVersionPathName dflags = do
|
||||
candidates <- case ghcVersionFile dflags of
|
||||
Just path -> return [path]
|
||||
Nothing -> (map (</> "ghcversion.h")) <$>
|
||||
(getPackageIncludePath dflags [toInstalledUnitId rtsUnit])
|
||||
|
||||
found <- filterM doesFileExist candidates
|
||||
case found of
|
||||
[] -> throwGhcExceptionIO (InstallationError
|
||||
("ghcversion.h missing; tried: "
|
||||
++ intercalate ", " candidates))
|
||||
(x:_) -> return x
|
||||
|
||||
rtsUnit :: UnitId
|
||||
rtsUnit = Module.rtsUnitId
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
-- 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.
|
||||
-- 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
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
|
||||
-- | Re-export 'doCpp' for GHC < 8.10.
|
||||
--
|
||||
-- Later versions export what we need.
|
||||
module Development.IDE.GHC.Compat.CPP (
|
||||
doCpp
|
||||
) where
|
||||
|
||||
import FileCleanup
|
||||
import Packages
|
||||
import Panic
|
||||
import SysTools
|
||||
#if MIN_VERSION_ghc(8,8,2)
|
||||
import LlvmCodeGen (llvmVersionList)
|
||||
#elif MIN_VERSION_ghc(8,8,0)
|
||||
import LlvmCodeGen (LlvmVersion (..))
|
||||
#endif
|
||||
import Control.Monad
|
||||
import Data.List (intercalate)
|
||||
import Data.Maybe
|
||||
import Data.Version
|
||||
import DynFlags
|
||||
import Module (rtsUnitId, toInstalledUnitId)
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.Info
|
||||
|
||||
import Development.IDE.GHC.Compat as Compat
|
||||
|
||||
doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
|
||||
doCpp dflags raw input_fn output_fn = do
|
||||
let hscpp_opts = picPOpts dflags
|
||||
let cmdline_include_paths = includePaths dflags
|
||||
|
||||
pkg_include_dirs <- getPackageIncludePath dflags []
|
||||
let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
|
||||
(includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
|
||||
let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
|
||||
(includePathsQuote cmdline_include_paths)
|
||||
let include_paths = include_paths_quote ++ include_paths_global
|
||||
|
||||
let verbFlags = getVerbFlags dflags
|
||||
|
||||
let cpp_prog args | raw = SysTools.runCpp dflags args
|
||||
#if MIN_VERSION_ghc(8,10,0)
|
||||
| otherwise = SysTools.runCc Nothing
|
||||
#else
|
||||
| otherwise = SysTools.runCc
|
||||
#endif
|
||||
dflags (SysTools.Option "-E" : args)
|
||||
|
||||
let target_defs =
|
||||
-- NEIL: Patched to use System.Info instead of constants from CPP
|
||||
[ "-D" ++ os ++ "_BUILD_OS",
|
||||
"-D" ++ arch ++ "_BUILD_ARCH",
|
||||
"-D" ++ os ++ "_HOST_OS",
|
||||
"-D" ++ arch ++ "_HOST_ARCH" ]
|
||||
-- remember, in code we *compile*, the HOST is the same our TARGET,
|
||||
-- and BUILD is the same as our HOST.
|
||||
|
||||
let sse_defs =
|
||||
[ "-D__SSE__" | isSseEnabled dflags ] ++
|
||||
[ "-D__SSE2__" | isSse2Enabled dflags ] ++
|
||||
[ "-D__SSE4_2__" | isSse4_2Enabled dflags ]
|
||||
|
||||
let avx_defs =
|
||||
[ "-D__AVX__" | isAvxEnabled dflags ] ++
|
||||
[ "-D__AVX2__" | isAvx2Enabled dflags ] ++
|
||||
[ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
|
||||
[ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
|
||||
[ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++
|
||||
[ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
|
||||
|
||||
backend_defs <- getBackendDefs dflags
|
||||
|
||||
let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
|
||||
-- Default CPP defines in Haskell source
|
||||
ghcVersionH <- getGhcVersionPathName dflags
|
||||
let hsSourceCppOpts = [ "-include", ghcVersionH ]
|
||||
|
||||
-- MIN_VERSION macros
|
||||
let uids = explicitPackages (pkgState dflags)
|
||||
pkgs = catMaybes (map (lookupPackage dflags) uids)
|
||||
mb_macro_include <-
|
||||
if not (null pkgs) && gopt Opt_VersionMacros dflags
|
||||
then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
|
||||
writeFile macro_stub (generatePackageVersionMacros pkgs)
|
||||
-- Include version macros for every *exposed* package.
|
||||
-- Without -hide-all-packages and with a package database
|
||||
-- size of 1000 packages, it takes cpp an estimated 2
|
||||
-- milliseconds to process this file. See #10970
|
||||
-- comment 8.
|
||||
return [SysTools.FileOption "-include" macro_stub]
|
||||
else return []
|
||||
|
||||
cpp_prog ( map SysTools.Option verbFlags
|
||||
++ map SysTools.Option include_paths
|
||||
++ map SysTools.Option hsSourceCppOpts
|
||||
++ map SysTools.Option target_defs
|
||||
++ map SysTools.Option backend_defs
|
||||
++ map SysTools.Option th_defs
|
||||
++ map SysTools.Option hscpp_opts
|
||||
++ map SysTools.Option sse_defs
|
||||
++ map SysTools.Option avx_defs
|
||||
++ mb_macro_include
|
||||
-- Set the language mode to assembler-with-cpp when preprocessing. This
|
||||
-- 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
|
||||
-- about this.
|
||||
++ [ SysTools.Option "-x"
|
||||
, SysTools.Option "assembler-with-cpp"
|
||||
, SysTools.Option input_fn
|
||||
-- We hackily use Option instead of FileOption here, so that the file
|
||||
-- name is not back-slashed on Windows. cpp is capable of
|
||||
-- dealing with / in filenames, so it works fine. Furthermore
|
||||
-- if we put in backslashes, cpp outputs #line directives
|
||||
-- with *double* backslashes. And that in turn means that
|
||||
-- our error messages get double backslashes in them.
|
||||
-- In due course we should arrange that the lexer deals
|
||||
-- with these \\ escapes properly.
|
||||
, SysTools.Option "-o"
|
||||
, SysTools.FileOption "" output_fn
|
||||
])
|
||||
|
||||
getBackendDefs :: DynFlags -> IO [String]
|
||||
getBackendDefs dflags | hscTarget dflags == HscLlvm = do
|
||||
llvmVer <- figureLlvmVersion dflags
|
||||
return $ case llvmVer of
|
||||
#if MIN_VERSION_ghc(8,8,2)
|
||||
Just v
|
||||
| [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ]
|
||||
| m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ]
|
||||
#elif MIN_VERSION_ghc(8,8,0)
|
||||
Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]
|
||||
Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
|
||||
#else
|
||||
Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]
|
||||
#endif
|
||||
_ -> []
|
||||
where
|
||||
format (major, minor)
|
||||
| minor >= 100 = error "getBackendDefs: Unsupported minor version"
|
||||
| otherwise = show $ (100 * major + minor :: Int) -- Contract is Int
|
||||
|
||||
getBackendDefs _ =
|
||||
return []
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Macros (cribbed from Cabal)
|
||||
|
||||
generatePackageVersionMacros :: [Compat.UnitInfo] -> String
|
||||
generatePackageVersionMacros pkgs = concat
|
||||
-- Do not add any C-style comments. See #3389.
|
||||
[ generateMacros "" pkgname version
|
||||
| pkg <- pkgs
|
||||
, let version = packageVersion pkg
|
||||
pkgname = map fixchar (packageNameString pkg)
|
||||
]
|
||||
|
||||
fixchar :: Char -> Char
|
||||
fixchar '-' = '_'
|
||||
fixchar c = c
|
||||
|
||||
generateMacros :: String -> String -> Version -> String
|
||||
generateMacros prefix name version =
|
||||
concat
|
||||
["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
|
||||
,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
|
||||
," (major1) < ",major1," || \\\n"
|
||||
," (major1) == ",major1," && (major2) < ",major2," || \\\n"
|
||||
," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
|
||||
,"\n\n"
|
||||
]
|
||||
where
|
||||
(major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
|
||||
|
||||
|
||||
-- | Find out path to @ghcversion.h@ file
|
||||
getGhcVersionPathName :: DynFlags -> IO FilePath
|
||||
getGhcVersionPathName dflags = do
|
||||
candidates <- case ghcVersionFile dflags of
|
||||
Just path -> return [path]
|
||||
Nothing -> (map (</> "ghcversion.h")) <$>
|
||||
(getPackageIncludePath dflags [toInstalledUnitId rtsUnit])
|
||||
|
||||
found <- filterM doesFileExist candidates
|
||||
case found of
|
||||
[] -> throwGhcExceptionIO (InstallationError
|
||||
("ghcversion.h missing; tried: "
|
||||
++ intercalate ", " candidates))
|
||||
(x:_) -> return x
|
||||
|
||||
rtsUnit :: UnitId
|
||||
rtsUnit = Module.rtsUnitId
|
||||
|
||||
@ -1,53 +1,53 @@
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
-- | Logging utilities for reporting heap statistics
|
||||
module Development.IDE.Main.HeapStats ( withHeapStats ) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Async
|
||||
import Control.Monad
|
||||
import qualified Data.Text as T
|
||||
import Data.Word
|
||||
import Development.IDE.Types.Logger (Logger, logInfo)
|
||||
import GHC.Stats
|
||||
import Text.Printf (printf)
|
||||
|
||||
-- | Interval at which to report the latest heap statistics.
|
||||
heapStatsInterval :: Int
|
||||
heapStatsInterval = 60_000_000 -- 60s
|
||||
|
||||
-- | Report the live bytes and heap size at the last major collection.
|
||||
logHeapStats :: Logger -> IO ()
|
||||
logHeapStats l = do
|
||||
stats <- getRTSStats
|
||||
-- live_bytes is the total amount of live memory in a program
|
||||
-- (corresponding to the amount on a heap profile)
|
||||
let live_bytes = gcdetails_live_bytes (gc stats)
|
||||
-- heap_size is the total amount of memory the RTS is using
|
||||
-- this corresponds closer to OS memory usage
|
||||
heap_size = gcdetails_mem_in_use_bytes (gc stats)
|
||||
format :: Word64 -> T.Text
|
||||
format m = T.pack (printf "%.2fMB" (fromIntegral @Word64 @Double m / 1e6))
|
||||
message = "Live bytes: " <> format live_bytes <> " " <>
|
||||
"Heap size: " <> format heap_size
|
||||
logInfo l message
|
||||
|
||||
-- | An action which logs heap statistics at the 'heapStatsInterval'
|
||||
heapStatsThread :: Logger -> IO r
|
||||
heapStatsThread l = forever $ do
|
||||
threadDelay heapStatsInterval
|
||||
logHeapStats l
|
||||
|
||||
-- | A helper function which lauches the 'heapStatsThread' and kills it
|
||||
-- appropiately when the inner action finishes. It also checks to see
|
||||
-- if `-T` is enabled.
|
||||
withHeapStats :: Logger -> IO r -> IO r
|
||||
withHeapStats l k = do
|
||||
enabled <- getRTSStatsEnabled
|
||||
if enabled
|
||||
then do
|
||||
logInfo l ("Logging heap statistics every "
|
||||
<> T.pack (printf "%.2fs" (fromIntegral @Int @Double heapStatsInterval / 1e6)))
|
||||
withAsync (heapStatsThread l) (const k)
|
||||
else do
|
||||
logInfo l "Heap statistics are not enabled (RTS option -T is needed)"
|
||||
k
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
-- | Logging utilities for reporting heap statistics
|
||||
module Development.IDE.Main.HeapStats ( withHeapStats ) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Async
|
||||
import Control.Monad
|
||||
import qualified Data.Text as T
|
||||
import Data.Word
|
||||
import Development.IDE.Types.Logger (Logger, logInfo)
|
||||
import GHC.Stats
|
||||
import Text.Printf (printf)
|
||||
|
||||
-- | Interval at which to report the latest heap statistics.
|
||||
heapStatsInterval :: Int
|
||||
heapStatsInterval = 60_000_000 -- 60s
|
||||
|
||||
-- | Report the live bytes and heap size at the last major collection.
|
||||
logHeapStats :: Logger -> IO ()
|
||||
logHeapStats l = do
|
||||
stats <- getRTSStats
|
||||
-- live_bytes is the total amount of live memory in a program
|
||||
-- (corresponding to the amount on a heap profile)
|
||||
let live_bytes = gcdetails_live_bytes (gc stats)
|
||||
-- heap_size is the total amount of memory the RTS is using
|
||||
-- this corresponds closer to OS memory usage
|
||||
heap_size = gcdetails_mem_in_use_bytes (gc stats)
|
||||
format :: Word64 -> T.Text
|
||||
format m = T.pack (printf "%.2fMB" (fromIntegral @Word64 @Double m / 1e6))
|
||||
message = "Live bytes: " <> format live_bytes <> " " <>
|
||||
"Heap size: " <> format heap_size
|
||||
logInfo l message
|
||||
|
||||
-- | An action which logs heap statistics at the 'heapStatsInterval'
|
||||
heapStatsThread :: Logger -> IO r
|
||||
heapStatsThread l = forever $ do
|
||||
threadDelay heapStatsInterval
|
||||
logHeapStats l
|
||||
|
||||
-- | A helper function which lauches the 'heapStatsThread' and kills it
|
||||
-- appropiately when the inner action finishes. It also checks to see
|
||||
-- if `-T` is enabled.
|
||||
withHeapStats :: Logger -> IO r -> IO r
|
||||
withHeapStats l k = do
|
||||
enabled <- getRTSStatsEnabled
|
||||
if enabled
|
||||
then do
|
||||
logInfo l ("Logging heap statistics every "
|
||||
<> T.pack (printf "%.2fs" (fromIntegral @Int @Double heapStatsInterval / 1e6)))
|
||||
withAsync (heapStatsThread l) (const k)
|
||||
else do
|
||||
logInfo l "Heap statistics are not enabled (RTS option -T is needed)"
|
||||
k
|
||||
|
||||
@ -31,7 +31,7 @@ import Data.Function (on)
|
||||
import Data.Functor
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.HashSet as HashSet
|
||||
import Data.Monoid (First(..))
|
||||
import Data.Monoid (First (..))
|
||||
import Data.Ord (Down (Down))
|
||||
import qualified Data.Set as Set
|
||||
import Development.IDE.Core.Compile
|
||||
|
||||
@ -1,224 +1,224 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Development.IDE.Spans.Documentation (
|
||||
getDocumentation
|
||||
, getDocumentationTryGhc
|
||||
, getDocumentationsTryGhc
|
||||
, DocMap
|
||||
, mkDocMap
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Extra (findM)
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Either
|
||||
import Data.Foldable
|
||||
import Data.List.Extra
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE.Core.Compile
|
||||
import Development.IDE.Core.RuleTypes
|
||||
import Development.IDE.GHC.Compat
|
||||
import Development.IDE.GHC.Compat.Util
|
||||
import Development.IDE.GHC.Error
|
||||
import Development.IDE.Spans.Common
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
|
||||
import Language.LSP.Types (filePathToUri, getUri)
|
||||
|
||||
mkDocMap
|
||||
:: HscEnv
|
||||
-> RefMap a
|
||||
-> TcGblEnv
|
||||
-> IO DocAndKindMap
|
||||
mkDocMap env rm this_mod =
|
||||
do
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
(_ , DeclDocMap this_docs, _) <- extractDocs this_mod
|
||||
#else
|
||||
let (_ , DeclDocMap this_docs, _) = extractDocs this_mod
|
||||
#endif
|
||||
d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names
|
||||
k <- foldrM getType (tcg_type_env this_mod) names
|
||||
pure $ DKMap d k
|
||||
where
|
||||
getDocs n map
|
||||
| maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist
|
||||
| otherwise = do
|
||||
doc <- getDocumentationTryGhc env mod n
|
||||
pure $ extendNameEnv map n doc
|
||||
getType n map
|
||||
| isTcOcc $ occName n = do
|
||||
kind <- lookupKind env mod n
|
||||
pure $ maybe map (extendNameEnv map n) kind
|
||||
| otherwise = pure map
|
||||
names = rights $ S.toList idents
|
||||
idents = M.keysSet rm
|
||||
mod = tcg_mod this_mod
|
||||
|
||||
lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing)
|
||||
lookupKind env mod =
|
||||
fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod
|
||||
|
||||
getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc
|
||||
getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n]
|
||||
|
||||
getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc]
|
||||
getDocumentationsTryGhc env mod names = do
|
||||
res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names
|
||||
case res of
|
||||
Left _ -> return []
|
||||
Right res -> zipWithM unwrap res names
|
||||
where
|
||||
unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n
|
||||
unwrap _ n = mkSpanDocText n
|
||||
|
||||
mkSpanDocText name =
|
||||
SpanDocText [] <$> getUris name
|
||||
|
||||
-- Get the uris to the documentation and source html pages if they exist
|
||||
getUris name = do
|
||||
(docFu, srcFu) <-
|
||||
case nameModule_maybe name of
|
||||
Just mod -> liftIO $ do
|
||||
doc <- toFileUriText $ lookupDocHtmlForModule env mod
|
||||
src <- toFileUriText $ lookupSrcHtmlForModule env mod
|
||||
return (doc, src)
|
||||
Nothing -> pure (Nothing, Nothing)
|
||||
let docUri = (<> "#" <> selector <> showNameWithoutUniques name) <$> docFu
|
||||
srcUri = (<> "#" <> showNameWithoutUniques name) <$> srcFu
|
||||
selector
|
||||
| isValName name = "v:"
|
||||
| otherwise = "t:"
|
||||
return $ SpanDocUris docUri srcUri
|
||||
|
||||
toFileUriText = (fmap . fmap) (getUri . filePathToUri)
|
||||
|
||||
getDocumentation
|
||||
:: HasSrcSpan name
|
||||
=> [ParsedModule] -- ^ All of the possible modules it could be defined in.
|
||||
-> name -- ^ The name you want documentation for.
|
||||
-> [T.Text]
|
||||
-- This finds any documentation between the name you want
|
||||
-- documentation for and the one before it. This is only an
|
||||
-- approximately correct algorithm and there are easily constructed
|
||||
-- cases where it will be wrong (if so then usually slightly but there
|
||||
-- may be edge cases where it is very wrong).
|
||||
-- TODO : Build a version of GHC exactprint to extract this information
|
||||
-- more accurately.
|
||||
-- TODO : Implement this for GHC 9.2 with in-tree annotations
|
||||
-- (alternatively, just remove it and rely soley on GHC's parsing)
|
||||
getDocumentation sources targetName = fromMaybe [] $ do
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
Nothing
|
||||
#else
|
||||
-- Find the module the target is defined in.
|
||||
targetNameSpan <- realSpan $ getLoc targetName
|
||||
tc <-
|
||||
find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)
|
||||
$ reverse sources -- TODO : Is reversing the list here really neccessary?
|
||||
|
||||
-- Top level names bound by the module
|
||||
let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc
|
||||
, L _ (ValD _ hsbind) <- hsmodDecls
|
||||
, Just n <- [name_of_bind hsbind]
|
||||
]
|
||||
-- Sort the names' source spans.
|
||||
let sortedSpans = sortedNameSpans bs
|
||||
-- Now go ahead and extract the docs.
|
||||
let docs = ann tc
|
||||
nameInd <- elemIndex targetNameSpan sortedSpans
|
||||
let prevNameSpan =
|
||||
if nameInd >= 1
|
||||
then sortedSpans !! (nameInd - 1)
|
||||
else zeroSpan $ srcSpanFile targetNameSpan
|
||||
-- Annoyingly "-- |" documentation isn't annotated with a location,
|
||||
-- so you have to pull it out from the elements.
|
||||
pure
|
||||
$ docHeaders
|
||||
$ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan)
|
||||
$ fold
|
||||
docs
|
||||
where
|
||||
-- Get the name bound by a binding. We only concern ourselves with
|
||||
-- @FunBind@ (which covers functions and variables).
|
||||
name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)
|
||||
name_of_bind FunBind {fun_id} = Just fun_id
|
||||
name_of_bind _ = Nothing
|
||||
-- Get source spans from names, discard unhelpful spans, remove
|
||||
-- duplicates and sort.
|
||||
sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]
|
||||
sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)
|
||||
isBetween target before after = before <= target && target <= after
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
ann = apiAnnComments . pm_annotations
|
||||
#else
|
||||
ann = fmap filterReal . snd . pm_annotations
|
||||
filterReal :: [Located a] -> [RealLocated a]
|
||||
filterReal = mapMaybe (\(L l v) -> (`L`v) <$> realSpan l)
|
||||
#endif
|
||||
annotationFileName :: ParsedModule -> Maybe FastString
|
||||
annotationFileName = fmap srcSpanFile . listToMaybe . map getRealSrcSpan . fold . ann
|
||||
|
||||
-- | Shows this part of the documentation
|
||||
docHeaders :: [RealLocated AnnotationComment]
|
||||
-> [T.Text]
|
||||
docHeaders = mapMaybe (\(L _ x) -> wrk x)
|
||||
where
|
||||
wrk = \case
|
||||
-- When `Opt_Haddock` is enabled.
|
||||
AnnDocCommentNext s -> Just $ T.pack s
|
||||
-- When `Opt_KeepRawTokenStream` enabled.
|
||||
AnnLineComment s -> if "-- |" `isPrefixOf` s
|
||||
then Just $ T.pack s
|
||||
else Nothing
|
||||
_ -> Nothing
|
||||
#endif
|
||||
|
||||
-- These are taken from haskell-ide-engine's Haddock plugin
|
||||
|
||||
-- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page.
|
||||
-- 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@
|
||||
lookupDocHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath)
|
||||
lookupDocHtmlForModule =
|
||||
lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> modDocName <.> "html")
|
||||
|
||||
-- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page.
|
||||
-- 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@
|
||||
lookupSrcHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath)
|
||||
lookupSrcHtmlForModule =
|
||||
lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> "src" </> modDocName <.> "html")
|
||||
|
||||
lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> HscEnv -> Module -> IO (Maybe FilePath)
|
||||
lookupHtmlForModule mkDocPath hscEnv m = do
|
||||
-- try all directories
|
||||
let mfs = fmap (concatMap go) (lookupHtmls hscEnv ui)
|
||||
html <- findM doesFileExist (concat . maybeToList $ mfs)
|
||||
-- canonicalize located html to remove /../ indirection which can break some clients
|
||||
-- (vscode on Windows at least)
|
||||
traverse canonicalizePath html
|
||||
where
|
||||
go pkgDocDir = map (mkDocPath pkgDocDir) mns
|
||||
ui = moduleUnit m
|
||||
-- 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
|
||||
-- then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc.
|
||||
mns = do
|
||||
chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m
|
||||
-- The file might use "." or "-" as separator
|
||||
map (`intercalate` chunks) [".", "-"]
|
||||
|
||||
lookupHtmls :: HscEnv -> Unit -> Maybe [FilePath]
|
||||
lookupHtmls df ui =
|
||||
-- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path
|
||||
-- and therefore doesn't expand $topdir on Windows
|
||||
map takeDirectory . unitHaddockInterfaces <$> lookupUnit df ui
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Development.IDE.Spans.Documentation (
|
||||
getDocumentation
|
||||
, getDocumentationTryGhc
|
||||
, getDocumentationsTryGhc
|
||||
, DocMap
|
||||
, mkDocMap
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Extra (findM)
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Either
|
||||
import Data.Foldable
|
||||
import Data.List.Extra
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE.Core.Compile
|
||||
import Development.IDE.Core.RuleTypes
|
||||
import Development.IDE.GHC.Compat
|
||||
import Development.IDE.GHC.Compat.Util
|
||||
import Development.IDE.GHC.Error
|
||||
import Development.IDE.Spans.Common
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
|
||||
import Language.LSP.Types (filePathToUri, getUri)
|
||||
|
||||
mkDocMap
|
||||
:: HscEnv
|
||||
-> RefMap a
|
||||
-> TcGblEnv
|
||||
-> IO DocAndKindMap
|
||||
mkDocMap env rm this_mod =
|
||||
do
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
(_ , DeclDocMap this_docs, _) <- extractDocs this_mod
|
||||
#else
|
||||
let (_ , DeclDocMap this_docs, _) = extractDocs this_mod
|
||||
#endif
|
||||
d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names
|
||||
k <- foldrM getType (tcg_type_env this_mod) names
|
||||
pure $ DKMap d k
|
||||
where
|
||||
getDocs n map
|
||||
| maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist
|
||||
| otherwise = do
|
||||
doc <- getDocumentationTryGhc env mod n
|
||||
pure $ extendNameEnv map n doc
|
||||
getType n map
|
||||
| isTcOcc $ occName n = do
|
||||
kind <- lookupKind env mod n
|
||||
pure $ maybe map (extendNameEnv map n) kind
|
||||
| otherwise = pure map
|
||||
names = rights $ S.toList idents
|
||||
idents = M.keysSet rm
|
||||
mod = tcg_mod this_mod
|
||||
|
||||
lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing)
|
||||
lookupKind env mod =
|
||||
fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod
|
||||
|
||||
getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc
|
||||
getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n]
|
||||
|
||||
getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc]
|
||||
getDocumentationsTryGhc env mod names = do
|
||||
res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names
|
||||
case res of
|
||||
Left _ -> return []
|
||||
Right res -> zipWithM unwrap res names
|
||||
where
|
||||
unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n
|
||||
unwrap _ n = mkSpanDocText n
|
||||
|
||||
mkSpanDocText name =
|
||||
SpanDocText [] <$> getUris name
|
||||
|
||||
-- Get the uris to the documentation and source html pages if they exist
|
||||
getUris name = do
|
||||
(docFu, srcFu) <-
|
||||
case nameModule_maybe name of
|
||||
Just mod -> liftIO $ do
|
||||
doc <- toFileUriText $ lookupDocHtmlForModule env mod
|
||||
src <- toFileUriText $ lookupSrcHtmlForModule env mod
|
||||
return (doc, src)
|
||||
Nothing -> pure (Nothing, Nothing)
|
||||
let docUri = (<> "#" <> selector <> showNameWithoutUniques name) <$> docFu
|
||||
srcUri = (<> "#" <> showNameWithoutUniques name) <$> srcFu
|
||||
selector
|
||||
| isValName name = "v:"
|
||||
| otherwise = "t:"
|
||||
return $ SpanDocUris docUri srcUri
|
||||
|
||||
toFileUriText = (fmap . fmap) (getUri . filePathToUri)
|
||||
|
||||
getDocumentation
|
||||
:: HasSrcSpan name
|
||||
=> [ParsedModule] -- ^ All of the possible modules it could be defined in.
|
||||
-> name -- ^ The name you want documentation for.
|
||||
-> [T.Text]
|
||||
-- This finds any documentation between the name you want
|
||||
-- documentation for and the one before it. This is only an
|
||||
-- approximately correct algorithm and there are easily constructed
|
||||
-- cases where it will be wrong (if so then usually slightly but there
|
||||
-- may be edge cases where it is very wrong).
|
||||
-- TODO : Build a version of GHC exactprint to extract this information
|
||||
-- more accurately.
|
||||
-- TODO : Implement this for GHC 9.2 with in-tree annotations
|
||||
-- (alternatively, just remove it and rely soley on GHC's parsing)
|
||||
getDocumentation sources targetName = fromMaybe [] $ do
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
Nothing
|
||||
#else
|
||||
-- Find the module the target is defined in.
|
||||
targetNameSpan <- realSpan $ getLoc targetName
|
||||
tc <-
|
||||
find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)
|
||||
$ reverse sources -- TODO : Is reversing the list here really neccessary?
|
||||
|
||||
-- Top level names bound by the module
|
||||
let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc
|
||||
, L _ (ValD _ hsbind) <- hsmodDecls
|
||||
, Just n <- [name_of_bind hsbind]
|
||||
]
|
||||
-- Sort the names' source spans.
|
||||
let sortedSpans = sortedNameSpans bs
|
||||
-- Now go ahead and extract the docs.
|
||||
let docs = ann tc
|
||||
nameInd <- elemIndex targetNameSpan sortedSpans
|
||||
let prevNameSpan =
|
||||
if nameInd >= 1
|
||||
then sortedSpans !! (nameInd - 1)
|
||||
else zeroSpan $ srcSpanFile targetNameSpan
|
||||
-- Annoyingly "-- |" documentation isn't annotated with a location,
|
||||
-- so you have to pull it out from the elements.
|
||||
pure
|
||||
$ docHeaders
|
||||
$ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan)
|
||||
$ fold
|
||||
docs
|
||||
where
|
||||
-- Get the name bound by a binding. We only concern ourselves with
|
||||
-- @FunBind@ (which covers functions and variables).
|
||||
name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)
|
||||
name_of_bind FunBind {fun_id} = Just fun_id
|
||||
name_of_bind _ = Nothing
|
||||
-- Get source spans from names, discard unhelpful spans, remove
|
||||
-- duplicates and sort.
|
||||
sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]
|
||||
sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)
|
||||
isBetween target before after = before <= target && target <= after
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
ann = apiAnnComments . pm_annotations
|
||||
#else
|
||||
ann = fmap filterReal . snd . pm_annotations
|
||||
filterReal :: [Located a] -> [RealLocated a]
|
||||
filterReal = mapMaybe (\(L l v) -> (`L`v) <$> realSpan l)
|
||||
#endif
|
||||
annotationFileName :: ParsedModule -> Maybe FastString
|
||||
annotationFileName = fmap srcSpanFile . listToMaybe . map getRealSrcSpan . fold . ann
|
||||
|
||||
-- | Shows this part of the documentation
|
||||
docHeaders :: [RealLocated AnnotationComment]
|
||||
-> [T.Text]
|
||||
docHeaders = mapMaybe (\(L _ x) -> wrk x)
|
||||
where
|
||||
wrk = \case
|
||||
-- When `Opt_Haddock` is enabled.
|
||||
AnnDocCommentNext s -> Just $ T.pack s
|
||||
-- When `Opt_KeepRawTokenStream` enabled.
|
||||
AnnLineComment s -> if "-- |" `isPrefixOf` s
|
||||
then Just $ T.pack s
|
||||
else Nothing
|
||||
_ -> Nothing
|
||||
#endif
|
||||
|
||||
-- These are taken from haskell-ide-engine's Haddock plugin
|
||||
|
||||
-- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page.
|
||||
-- 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@
|
||||
lookupDocHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath)
|
||||
lookupDocHtmlForModule =
|
||||
lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> modDocName <.> "html")
|
||||
|
||||
-- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page.
|
||||
-- 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@
|
||||
lookupSrcHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath)
|
||||
lookupSrcHtmlForModule =
|
||||
lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> "src" </> modDocName <.> "html")
|
||||
|
||||
lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> HscEnv -> Module -> IO (Maybe FilePath)
|
||||
lookupHtmlForModule mkDocPath hscEnv m = do
|
||||
-- try all directories
|
||||
let mfs = fmap (concatMap go) (lookupHtmls hscEnv ui)
|
||||
html <- findM doesFileExist (concat . maybeToList $ mfs)
|
||||
-- canonicalize located html to remove /../ indirection which can break some clients
|
||||
-- (vscode on Windows at least)
|
||||
traverse canonicalizePath html
|
||||
where
|
||||
go pkgDocDir = map (mkDocPath pkgDocDir) mns
|
||||
ui = moduleUnit m
|
||||
-- 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
|
||||
-- then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc.
|
||||
mns = do
|
||||
chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m
|
||||
-- The file might use "." or "-" as separator
|
||||
map (`intercalate` chunks) [".", "-"]
|
||||
|
||||
lookupHtmls :: HscEnv -> Unit -> Maybe [FilePath]
|
||||
lookupHtmls df ui =
|
||||
-- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path
|
||||
-- and therefore doesn't expand $topdir on Windows
|
||||
map takeDirectory . unitHaddockInterfaces <$> lookupUnit df ui
|
||||
|
||||
@ -1,140 +1,140 @@
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
|
||||
module Development.IDE.Spans.LocalBindings
|
||||
( Bindings
|
||||
, getLocalScope
|
||||
, getFuzzyScope
|
||||
, getDefiningBindings
|
||||
, getFuzzyDefiningBindings
|
||||
, bindings
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Control.Monad
|
||||
import Data.Bifunctor
|
||||
import Data.IntervalMap.FingerTree (Interval (..), IntervalMap)
|
||||
import qualified Data.IntervalMap.FingerTree as IM
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import Development.IDE.GHC.Compat (Name, NameEnv, RealSrcSpan,
|
||||
RefMap, Scope (..), Type,
|
||||
getBindSiteFromContext,
|
||||
getScopeFromContext, identInfo,
|
||||
identType, isSystemName,
|
||||
nameEnvElts, realSrcSpanEnd,
|
||||
realSrcSpanStart, unitNameEnv)
|
||||
|
||||
import Development.IDE.GHC.Error
|
||||
import Development.IDE.Types.Location
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Turn a 'RealSrcSpan' into an 'Interval'.
|
||||
realSrcSpanToInterval :: RealSrcSpan -> Interval Position
|
||||
realSrcSpanToInterval rss =
|
||||
Interval
|
||||
(realSrcLocToPosition $ realSrcSpanStart rss)
|
||||
(realSrcLocToPosition $ realSrcSpanEnd rss)
|
||||
|
||||
bindings :: RefMap Type -> Bindings
|
||||
bindings = uncurry Bindings . localBindings
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Compute which identifiers are in scope at every point in the AST. Use
|
||||
-- 'getLocalScope' to find the results.
|
||||
localBindings
|
||||
:: RefMap Type
|
||||
-> ( IntervalMap Position (NameEnv (Name, Maybe Type))
|
||||
, IntervalMap Position (NameEnv (Name, Maybe Type))
|
||||
)
|
||||
localBindings refmap = bimap mk mk $ unzip $ do
|
||||
(ident, refs) <- M.toList refmap
|
||||
Right name <- pure ident
|
||||
(_, ident_details) <- refs
|
||||
let ty = identType ident_details
|
||||
info <- S.toList $ identInfo ident_details
|
||||
pure
|
||||
( do
|
||||
Just scopes <- pure $ getScopeFromContext info
|
||||
scope <- scopes >>= \case
|
||||
LocalScope scope -> pure $ realSrcSpanToInterval scope
|
||||
_ -> []
|
||||
pure ( scope
|
||||
, unitNameEnv name (name,ty)
|
||||
)
|
||||
, do
|
||||
Just scope <- pure $ getBindSiteFromContext info
|
||||
pure ( realSrcSpanToInterval scope
|
||||
, unitNameEnv name (name,ty)
|
||||
)
|
||||
)
|
||||
where
|
||||
mk = L.foldl' (flip (uncurry IM.insert)) mempty . join
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | The available bindings at every point in a Haskell tree.
|
||||
data Bindings = Bindings
|
||||
{ getLocalBindings
|
||||
:: IntervalMap Position (NameEnv (Name, Maybe Type))
|
||||
, getBindingSites
|
||||
:: IntervalMap Position (NameEnv (Name, Maybe Type))
|
||||
}
|
||||
|
||||
instance Semigroup Bindings where
|
||||
Bindings a1 b1 <> Bindings a2 b2
|
||||
= Bindings (a1 <> a2) (b1 <> b2)
|
||||
|
||||
instance Monoid Bindings where
|
||||
mempty = Bindings mempty mempty
|
||||
|
||||
instance NFData Bindings where
|
||||
rnf = rwhnf
|
||||
|
||||
instance Show Bindings where
|
||||
show _ = "<bindings>"
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given a 'Bindings' get every identifier in scope at the given
|
||||
-- 'RealSrcSpan',
|
||||
getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)]
|
||||
getLocalScope bs rss
|
||||
= nameEnvElts
|
||||
$ foldMap snd
|
||||
$ IM.dominators (realSrcSpanToInterval rss)
|
||||
$ getLocalBindings bs
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given a 'Bindings', get every binding currently active at a given
|
||||
-- 'RealSrcSpan',
|
||||
getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)]
|
||||
getDefiningBindings bs rss
|
||||
= nameEnvElts
|
||||
$ foldMap snd
|
||||
$ IM.dominators (realSrcSpanToInterval rss)
|
||||
$ getBindingSites bs
|
||||
|
||||
|
||||
-- | Lookup all names in scope in any span that intersects the interval
|
||||
-- defined by the two positions.
|
||||
-- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping`
|
||||
getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)]
|
||||
getFuzzyScope bs a b
|
||||
= filter (not . isSystemName . fst)
|
||||
$ nameEnvElts
|
||||
$ foldMap snd
|
||||
$ IM.intersections (Interval a b)
|
||||
$ getLocalBindings bs
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given a 'Bindings', get every binding that intersects the interval defined
|
||||
-- by the two positions.
|
||||
-- This is meant for use with the fuzzy `PositionRange` returned by
|
||||
-- `PositionMapping`
|
||||
getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)]
|
||||
getFuzzyDefiningBindings bs a b
|
||||
= nameEnvElts
|
||||
$ foldMap snd
|
||||
$ IM.intersections (Interval a b)
|
||||
$ getBindingSites bs
|
||||
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
|
||||
module Development.IDE.Spans.LocalBindings
|
||||
( Bindings
|
||||
, getLocalScope
|
||||
, getFuzzyScope
|
||||
, getDefiningBindings
|
||||
, getFuzzyDefiningBindings
|
||||
, bindings
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Control.Monad
|
||||
import Data.Bifunctor
|
||||
import Data.IntervalMap.FingerTree (Interval (..), IntervalMap)
|
||||
import qualified Data.IntervalMap.FingerTree as IM
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import Development.IDE.GHC.Compat (Name, NameEnv, RealSrcSpan,
|
||||
RefMap, Scope (..), Type,
|
||||
getBindSiteFromContext,
|
||||
getScopeFromContext, identInfo,
|
||||
identType, isSystemName,
|
||||
nameEnvElts, realSrcSpanEnd,
|
||||
realSrcSpanStart, unitNameEnv)
|
||||
|
||||
import Development.IDE.GHC.Error
|
||||
import Development.IDE.Types.Location
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Turn a 'RealSrcSpan' into an 'Interval'.
|
||||
realSrcSpanToInterval :: RealSrcSpan -> Interval Position
|
||||
realSrcSpanToInterval rss =
|
||||
Interval
|
||||
(realSrcLocToPosition $ realSrcSpanStart rss)
|
||||
(realSrcLocToPosition $ realSrcSpanEnd rss)
|
||||
|
||||
bindings :: RefMap Type -> Bindings
|
||||
bindings = uncurry Bindings . localBindings
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Compute which identifiers are in scope at every point in the AST. Use
|
||||
-- 'getLocalScope' to find the results.
|
||||
localBindings
|
||||
:: RefMap Type
|
||||
-> ( IntervalMap Position (NameEnv (Name, Maybe Type))
|
||||
, IntervalMap Position (NameEnv (Name, Maybe Type))
|
||||
)
|
||||
localBindings refmap = bimap mk mk $ unzip $ do
|
||||
(ident, refs) <- M.toList refmap
|
||||
Right name <- pure ident
|
||||
(_, ident_details) <- refs
|
||||
let ty = identType ident_details
|
||||
info <- S.toList $ identInfo ident_details
|
||||
pure
|
||||
( do
|
||||
Just scopes <- pure $ getScopeFromContext info
|
||||
scope <- scopes >>= \case
|
||||
LocalScope scope -> pure $ realSrcSpanToInterval scope
|
||||
_ -> []
|
||||
pure ( scope
|
||||
, unitNameEnv name (name,ty)
|
||||
)
|
||||
, do
|
||||
Just scope <- pure $ getBindSiteFromContext info
|
||||
pure ( realSrcSpanToInterval scope
|
||||
, unitNameEnv name (name,ty)
|
||||
)
|
||||
)
|
||||
where
|
||||
mk = L.foldl' (flip (uncurry IM.insert)) mempty . join
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | The available bindings at every point in a Haskell tree.
|
||||
data Bindings = Bindings
|
||||
{ getLocalBindings
|
||||
:: IntervalMap Position (NameEnv (Name, Maybe Type))
|
||||
, getBindingSites
|
||||
:: IntervalMap Position (NameEnv (Name, Maybe Type))
|
||||
}
|
||||
|
||||
instance Semigroup Bindings where
|
||||
Bindings a1 b1 <> Bindings a2 b2
|
||||
= Bindings (a1 <> a2) (b1 <> b2)
|
||||
|
||||
instance Monoid Bindings where
|
||||
mempty = Bindings mempty mempty
|
||||
|
||||
instance NFData Bindings where
|
||||
rnf = rwhnf
|
||||
|
||||
instance Show Bindings where
|
||||
show _ = "<bindings>"
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given a 'Bindings' get every identifier in scope at the given
|
||||
-- 'RealSrcSpan',
|
||||
getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)]
|
||||
getLocalScope bs rss
|
||||
= nameEnvElts
|
||||
$ foldMap snd
|
||||
$ IM.dominators (realSrcSpanToInterval rss)
|
||||
$ getLocalBindings bs
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given a 'Bindings', get every binding currently active at a given
|
||||
-- 'RealSrcSpan',
|
||||
getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)]
|
||||
getDefiningBindings bs rss
|
||||
= nameEnvElts
|
||||
$ foldMap snd
|
||||
$ IM.dominators (realSrcSpanToInterval rss)
|
||||
$ getBindingSites bs
|
||||
|
||||
|
||||
-- | Lookup all names in scope in any span that intersects the interval
|
||||
-- defined by the two positions.
|
||||
-- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping`
|
||||
getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)]
|
||||
getFuzzyScope bs a b
|
||||
= filter (not . isSystemName . fst)
|
||||
$ nameEnvElts
|
||||
$ foldMap snd
|
||||
$ IM.intersections (Interval a b)
|
||||
$ getLocalBindings bs
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given a 'Bindings', get every binding that intersects the interval defined
|
||||
-- by the two positions.
|
||||
-- This is meant for use with the fuzzy `PositionRange` returned by
|
||||
-- `PositionMapping`
|
||||
getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)]
|
||||
getFuzzyDefiningBindings bs a b
|
||||
= nameEnvElts
|
||||
$ foldMap snd
|
||||
$ IM.intersections (Interval a b)
|
||||
$ getBindingSites bs
|
||||
|
||||
|
||||
@ -1,153 +1,153 @@
|
||||
module Development.IDE.Types.HscEnvEq
|
||||
( HscEnvEq,
|
||||
hscEnv, newHscEnvEq,
|
||||
hscEnvWithImportPaths,
|
||||
newHscEnvEqPreserveImportPaths,
|
||||
newHscEnvEqWithImportPaths,
|
||||
envImportPaths,
|
||||
envPackageExports,
|
||||
envVisibleModuleNames,
|
||||
deps
|
||||
) where
|
||||
|
||||
|
||||
import Control.Concurrent.Async (Async, async, waitCatch)
|
||||
import Control.Concurrent.Strict (modifyVar, newVar)
|
||||
import Control.DeepSeq (force)
|
||||
import Control.Exception (evaluate, mask, throwIO)
|
||||
import Control.Monad.Extra (eitherM, join, mapMaybeM)
|
||||
import Data.Either (fromRight)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Unique (Unique)
|
||||
import qualified Data.Unique as Unique
|
||||
import Development.IDE.GHC.Compat
|
||||
import qualified Development.IDE.GHC.Compat.Util as Maybes
|
||||
import Development.IDE.GHC.Error (catchSrcErrors)
|
||||
import Development.IDE.GHC.Util (lookupPackageConfig)
|
||||
import Development.IDE.Graph.Classes
|
||||
import Development.IDE.Types.Exports (ExportsMap, createExportsMap)
|
||||
import OpenTelemetry.Eventlog (withSpan)
|
||||
import System.Directory (makeAbsolute)
|
||||
import System.FilePath
|
||||
|
||||
-- | An 'HscEnv' with equality. Two values are considered equal
|
||||
-- if they are created with the same call to 'newHscEnvEq'.
|
||||
data HscEnvEq = HscEnvEq
|
||||
{ envUnique :: !Unique
|
||||
, hscEnv :: !HscEnv
|
||||
, deps :: [(UnitId, DynFlags)]
|
||||
-- ^ In memory components for this HscEnv
|
||||
-- This is only used at the moment for the import dirs in
|
||||
-- the DynFlags
|
||||
, envImportPaths :: Maybe (Set FilePath)
|
||||
-- ^ If Just, import dirs originally configured in this env
|
||||
-- If Nothing, the env import dirs are unaltered
|
||||
, envPackageExports :: IO ExportsMap
|
||||
, envVisibleModuleNames :: IO (Maybe [ModuleName])
|
||||
-- ^ 'listVisibleModuleNames' is a pure function,
|
||||
-- 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
|
||||
-- If Nothing, 'listVisibleModuleNames' panic
|
||||
}
|
||||
|
||||
-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
|
||||
newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
|
||||
newHscEnvEq cradlePath hscEnv0 deps = do
|
||||
let relativeToCradle = (takeDirectory cradlePath </>)
|
||||
hscEnv = removeImportPaths hscEnv0
|
||||
|
||||
-- Make Absolute since targets are also absolute
|
||||
importPathsCanon <-
|
||||
mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0)
|
||||
|
||||
newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps
|
||||
|
||||
newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
|
||||
newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do
|
||||
|
||||
let dflags = hsc_dflags hscEnv
|
||||
|
||||
envUnique <- Unique.newUnique
|
||||
|
||||
-- it's very important to delay the package exports computation
|
||||
envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do
|
||||
-- compute the package imports
|
||||
let pkgst = unitState hscEnv
|
||||
depends = explicitUnits pkgst
|
||||
modules =
|
||||
[ m
|
||||
| d <- depends
|
||||
, Just pkg <- [lookupPackageConfig d hscEnv]
|
||||
, (modName, maybeOtherPkgMod) <- unitExposedModules pkg
|
||||
, let m = case maybeOtherPkgMod of
|
||||
-- When module is re-exported from another package,
|
||||
-- the origin module is represented by value in Just
|
||||
Just otherPkgMod -> otherPkgMod
|
||||
Nothing -> mkModule (unitInfoId pkg) modName
|
||||
]
|
||||
|
||||
doOne m = do
|
||||
modIface <- initIfaceLoad hscEnv $
|
||||
loadInterface "" m (ImportByUser NotBoot)
|
||||
return $ case modIface of
|
||||
Maybes.Failed _r -> Nothing
|
||||
Maybes.Succeeded mi -> Just mi
|
||||
modIfaces <- mapMaybeM doOne modules
|
||||
return $ createExportsMap modIfaces
|
||||
|
||||
-- similar to envPackageExports, evaluated lazily
|
||||
envVisibleModuleNames <- onceAsync $
|
||||
fromRight Nothing
|
||||
<$> catchSrcErrors
|
||||
dflags
|
||||
"listVisibleModuleNames"
|
||||
(evaluate . force . Just $ listVisibleModuleNames hscEnv)
|
||||
|
||||
return HscEnvEq{..}
|
||||
|
||||
-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
|
||||
newHscEnvEqPreserveImportPaths
|
||||
:: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
|
||||
newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing
|
||||
|
||||
-- | Unwrap the 'HscEnv' with the original import paths.
|
||||
-- Used only for locating imports
|
||||
hscEnvWithImportPaths :: HscEnvEq -> HscEnv
|
||||
hscEnvWithImportPaths HscEnvEq{..}
|
||||
| Just imps <- envImportPaths
|
||||
= hscSetFlags (setImportPaths (Set.toList imps) (hsc_dflags hscEnv)) hscEnv
|
||||
| otherwise
|
||||
= hscEnv
|
||||
|
||||
removeImportPaths :: HscEnv -> HscEnv
|
||||
removeImportPaths hsc = hscSetFlags (setImportPaths [] (hsc_dflags hsc)) hsc
|
||||
|
||||
instance Show HscEnvEq where
|
||||
show HscEnvEq{envUnique} = "HscEnvEq " ++ show (Unique.hashUnique envUnique)
|
||||
|
||||
instance Eq HscEnvEq where
|
||||
a == b = envUnique a == envUnique b
|
||||
|
||||
instance NFData HscEnvEq where
|
||||
rnf (HscEnvEq a b c d _ _) =
|
||||
-- deliberately skip the package exports map and visible module names
|
||||
rnf (Unique.hashUnique a) `seq` b `seq` c `seq` rnf d
|
||||
|
||||
instance Hashable HscEnvEq where
|
||||
hashWithSalt s = hashWithSalt s . envUnique
|
||||
|
||||
-- | 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
|
||||
-- If the function raises an exception, the same exception will be reraised each time.
|
||||
onceAsync :: IO a -> IO (IO a)
|
||||
onceAsync act = do
|
||||
var <- newVar OncePending
|
||||
let run as = eitherM throwIO pure (waitCatch as)
|
||||
pure $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of
|
||||
OnceRunning x -> pure (v, unmask $ run x)
|
||||
OncePending -> do
|
||||
x <- async (unmask act)
|
||||
pure (OnceRunning x, unmask $ run x)
|
||||
|
||||
data Once a = OncePending | OnceRunning (Async a)
|
||||
module Development.IDE.Types.HscEnvEq
|
||||
( HscEnvEq,
|
||||
hscEnv, newHscEnvEq,
|
||||
hscEnvWithImportPaths,
|
||||
newHscEnvEqPreserveImportPaths,
|
||||
newHscEnvEqWithImportPaths,
|
||||
envImportPaths,
|
||||
envPackageExports,
|
||||
envVisibleModuleNames,
|
||||
deps
|
||||
) where
|
||||
|
||||
|
||||
import Control.Concurrent.Async (Async, async, waitCatch)
|
||||
import Control.Concurrent.Strict (modifyVar, newVar)
|
||||
import Control.DeepSeq (force)
|
||||
import Control.Exception (evaluate, mask, throwIO)
|
||||
import Control.Monad.Extra (eitherM, join, mapMaybeM)
|
||||
import Data.Either (fromRight)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Unique (Unique)
|
||||
import qualified Data.Unique as Unique
|
||||
import Development.IDE.GHC.Compat
|
||||
import qualified Development.IDE.GHC.Compat.Util as Maybes
|
||||
import Development.IDE.GHC.Error (catchSrcErrors)
|
||||
import Development.IDE.GHC.Util (lookupPackageConfig)
|
||||
import Development.IDE.Graph.Classes
|
||||
import Development.IDE.Types.Exports (ExportsMap, createExportsMap)
|
||||
import OpenTelemetry.Eventlog (withSpan)
|
||||
import System.Directory (makeAbsolute)
|
||||
import System.FilePath
|
||||
|
||||
-- | An 'HscEnv' with equality. Two values are considered equal
|
||||
-- if they are created with the same call to 'newHscEnvEq'.
|
||||
data HscEnvEq = HscEnvEq
|
||||
{ envUnique :: !Unique
|
||||
, hscEnv :: !HscEnv
|
||||
, deps :: [(UnitId, DynFlags)]
|
||||
-- ^ In memory components for this HscEnv
|
||||
-- This is only used at the moment for the import dirs in
|
||||
-- the DynFlags
|
||||
, envImportPaths :: Maybe (Set FilePath)
|
||||
-- ^ If Just, import dirs originally configured in this env
|
||||
-- If Nothing, the env import dirs are unaltered
|
||||
, envPackageExports :: IO ExportsMap
|
||||
, envVisibleModuleNames :: IO (Maybe [ModuleName])
|
||||
-- ^ 'listVisibleModuleNames' is a pure function,
|
||||
-- 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
|
||||
-- If Nothing, 'listVisibleModuleNames' panic
|
||||
}
|
||||
|
||||
-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
|
||||
newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
|
||||
newHscEnvEq cradlePath hscEnv0 deps = do
|
||||
let relativeToCradle = (takeDirectory cradlePath </>)
|
||||
hscEnv = removeImportPaths hscEnv0
|
||||
|
||||
-- Make Absolute since targets are also absolute
|
||||
importPathsCanon <-
|
||||
mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0)
|
||||
|
||||
newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps
|
||||
|
||||
newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
|
||||
newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do
|
||||
|
||||
let dflags = hsc_dflags hscEnv
|
||||
|
||||
envUnique <- Unique.newUnique
|
||||
|
||||
-- it's very important to delay the package exports computation
|
||||
envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do
|
||||
-- compute the package imports
|
||||
let pkgst = unitState hscEnv
|
||||
depends = explicitUnits pkgst
|
||||
modules =
|
||||
[ m
|
||||
| d <- depends
|
||||
, Just pkg <- [lookupPackageConfig d hscEnv]
|
||||
, (modName, maybeOtherPkgMod) <- unitExposedModules pkg
|
||||
, let m = case maybeOtherPkgMod of
|
||||
-- When module is re-exported from another package,
|
||||
-- the origin module is represented by value in Just
|
||||
Just otherPkgMod -> otherPkgMod
|
||||
Nothing -> mkModule (unitInfoId pkg) modName
|
||||
]
|
||||
|
||||
doOne m = do
|
||||
modIface <- initIfaceLoad hscEnv $
|
||||
loadInterface "" m (ImportByUser NotBoot)
|
||||
return $ case modIface of
|
||||
Maybes.Failed _r -> Nothing
|
||||
Maybes.Succeeded mi -> Just mi
|
||||
modIfaces <- mapMaybeM doOne modules
|
||||
return $ createExportsMap modIfaces
|
||||
|
||||
-- similar to envPackageExports, evaluated lazily
|
||||
envVisibleModuleNames <- onceAsync $
|
||||
fromRight Nothing
|
||||
<$> catchSrcErrors
|
||||
dflags
|
||||
"listVisibleModuleNames"
|
||||
(evaluate . force . Just $ listVisibleModuleNames hscEnv)
|
||||
|
||||
return HscEnvEq{..}
|
||||
|
||||
-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
|
||||
newHscEnvEqPreserveImportPaths
|
||||
:: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
|
||||
newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing
|
||||
|
||||
-- | Unwrap the 'HscEnv' with the original import paths.
|
||||
-- Used only for locating imports
|
||||
hscEnvWithImportPaths :: HscEnvEq -> HscEnv
|
||||
hscEnvWithImportPaths HscEnvEq{..}
|
||||
| Just imps <- envImportPaths
|
||||
= hscSetFlags (setImportPaths (Set.toList imps) (hsc_dflags hscEnv)) hscEnv
|
||||
| otherwise
|
||||
= hscEnv
|
||||
|
||||
removeImportPaths :: HscEnv -> HscEnv
|
||||
removeImportPaths hsc = hscSetFlags (setImportPaths [] (hsc_dflags hsc)) hsc
|
||||
|
||||
instance Show HscEnvEq where
|
||||
show HscEnvEq{envUnique} = "HscEnvEq " ++ show (Unique.hashUnique envUnique)
|
||||
|
||||
instance Eq HscEnvEq where
|
||||
a == b = envUnique a == envUnique b
|
||||
|
||||
instance NFData HscEnvEq where
|
||||
rnf (HscEnvEq a b c d _ _) =
|
||||
-- deliberately skip the package exports map and visible module names
|
||||
rnf (Unique.hashUnique a) `seq` b `seq` c `seq` rnf d
|
||||
|
||||
instance Hashable HscEnvEq where
|
||||
hashWithSalt s = hashWithSalt s . envUnique
|
||||
|
||||
-- | 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
|
||||
-- If the function raises an exception, the same exception will be reraised each time.
|
||||
onceAsync :: IO a -> IO (IO a)
|
||||
onceAsync act = do
|
||||
var <- newVar OncePending
|
||||
let run as = eitherM throwIO pure (waitCatch as)
|
||||
pure $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of
|
||||
OnceRunning x -> pure (v, unmask $ run x)
|
||||
OncePending -> do
|
||||
x <- async (unmask act)
|
||||
pure (OnceRunning x, unmask $ run x)
|
||||
|
||||
data Once a = OncePending | OnceRunning (Async a)
|
||||
|
||||
@ -1,124 +1,124 @@
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
-- | Custom SYB traversals explicitly designed for operating over the GHC AST.
|
||||
module Generics.SYB.GHC
|
||||
( genericIsSubspan,
|
||||
mkBindListT,
|
||||
everywhereM',
|
||||
smallestM,
|
||||
largestM
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Functor.Compose (Compose (Compose))
|
||||
import Data.Monoid (Any (Any))
|
||||
import Development.IDE.GHC.Compat
|
||||
import Development.IDE.Graph.Classes
|
||||
import Generics.SYB
|
||||
|
||||
|
||||
-- | A generic query intended to be used for calling 'smallestM' and
|
||||
-- '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
|
||||
-- indicates uncertainty. The search strategy in 'smallestM' et al. will
|
||||
-- continue searching uncertain nodes.
|
||||
genericIsSubspan ::
|
||||
forall ast.
|
||||
Typeable ast =>
|
||||
-- | The type of nodes we'd like to consider.
|
||||
Proxy (Located ast) ->
|
||||
SrcSpan ->
|
||||
GenericQ (Maybe (Bool, ast))
|
||||
genericIsSubspan _ dst = mkQ Nothing $ \case
|
||||
(L span ast :: Located ast) -> Just (dst `isSubspanOf` span, ast)
|
||||
|
||||
|
||||
-- | 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
|
||||
-- 'everywhereM' or friends.
|
||||
--
|
||||
-- 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 f = mkM $ fmap join . traverse (uncurry f) . zip [0..]
|
||||
|
||||
|
||||
-- | Apply a monadic transformation everywhere in a top-down manner.
|
||||
everywhereM' :: forall m. Monad m => GenericM m -> GenericM m
|
||||
everywhereM' f = go
|
||||
where
|
||||
go :: GenericM m
|
||||
go = gmapM go <=< f
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Custom SYB machinery
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- | Generic monadic transformations that return side-channel data.
|
||||
type GenericMQ r m = forall a. Data a => a -> m (r, a)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Apply the given 'GenericM' at all every node whose children fail the
|
||||
-- 'GenericQ', but which passes the query itself.
|
||||
--
|
||||
-- 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
|
||||
-- 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
|
||||
-- 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
|
||||
-- used.
|
||||
smallestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m
|
||||
smallestM q f = fmap snd . go
|
||||
where
|
||||
go :: GenericMQ Any m
|
||||
go x = do
|
||||
case q x of
|
||||
Nothing -> gmapMQ go x
|
||||
Just (True, a) -> do
|
||||
it@(r, x') <- gmapMQ go x
|
||||
case r of
|
||||
Any True -> pure it
|
||||
Any False -> fmap (Any True,) $ f a x'
|
||||
Just (False, _) -> pure (mempty, x)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | 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
|
||||
-- root-first, this policy will find the largest subtrees for which the query
|
||||
-- holds true.
|
||||
--
|
||||
-- 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
|
||||
-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is
|
||||
-- used.
|
||||
largestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m
|
||||
largestM q f = go
|
||||
where
|
||||
go :: GenericM m
|
||||
go x = do
|
||||
case q x of
|
||||
Just (True, a) -> f a x
|
||||
Just (False, _) -> pure x
|
||||
Nothing -> gmapM go x
|
||||
|
||||
newtype MonadicQuery r m a = MonadicQuery
|
||||
{ runMonadicQuery :: m (r, a)
|
||||
}
|
||||
deriving stock (Functor)
|
||||
deriving Applicative via Compose m ((,) r)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Like 'gmapM', but also returns side-channel data.
|
||||
gmapMQ ::
|
||||
forall f r a. (Monoid r, Data a, Applicative f) =>
|
||||
(forall d. Data d => d -> f (r, d)) ->
|
||||
a ->
|
||||
f (r, a)
|
||||
gmapMQ f = runMonadicQuery . gfoldl k pure
|
||||
where
|
||||
k :: Data d => MonadicQuery r f (d -> b) -> d -> MonadicQuery r f b
|
||||
k c x = c <*> MonadicQuery (f x)
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
-- | Custom SYB traversals explicitly designed for operating over the GHC AST.
|
||||
module Generics.SYB.GHC
|
||||
( genericIsSubspan,
|
||||
mkBindListT,
|
||||
everywhereM',
|
||||
smallestM,
|
||||
largestM
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Functor.Compose (Compose (Compose))
|
||||
import Data.Monoid (Any (Any))
|
||||
import Development.IDE.GHC.Compat
|
||||
import Development.IDE.Graph.Classes
|
||||
import Generics.SYB
|
||||
|
||||
|
||||
-- | A generic query intended to be used for calling 'smallestM' and
|
||||
-- '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
|
||||
-- indicates uncertainty. The search strategy in 'smallestM' et al. will
|
||||
-- continue searching uncertain nodes.
|
||||
genericIsSubspan ::
|
||||
forall ast.
|
||||
Typeable ast =>
|
||||
-- | The type of nodes we'd like to consider.
|
||||
Proxy (Located ast) ->
|
||||
SrcSpan ->
|
||||
GenericQ (Maybe (Bool, ast))
|
||||
genericIsSubspan _ dst = mkQ Nothing $ \case
|
||||
(L span ast :: Located ast) -> Just (dst `isSubspanOf` span, ast)
|
||||
|
||||
|
||||
-- | 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
|
||||
-- 'everywhereM' or friends.
|
||||
--
|
||||
-- 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 f = mkM $ fmap join . traverse (uncurry f) . zip [0..]
|
||||
|
||||
|
||||
-- | Apply a monadic transformation everywhere in a top-down manner.
|
||||
everywhereM' :: forall m. Monad m => GenericM m -> GenericM m
|
||||
everywhereM' f = go
|
||||
where
|
||||
go :: GenericM m
|
||||
go = gmapM go <=< f
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Custom SYB machinery
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- | Generic monadic transformations that return side-channel data.
|
||||
type GenericMQ r m = forall a. Data a => a -> m (r, a)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Apply the given 'GenericM' at all every node whose children fail the
|
||||
-- 'GenericQ', but which passes the query itself.
|
||||
--
|
||||
-- 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
|
||||
-- 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
|
||||
-- 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
|
||||
-- used.
|
||||
smallestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m
|
||||
smallestM q f = fmap snd . go
|
||||
where
|
||||
go :: GenericMQ Any m
|
||||
go x = do
|
||||
case q x of
|
||||
Nothing -> gmapMQ go x
|
||||
Just (True, a) -> do
|
||||
it@(r, x') <- gmapMQ go x
|
||||
case r of
|
||||
Any True -> pure it
|
||||
Any False -> fmap (Any True,) $ f a x'
|
||||
Just (False, _) -> pure (mempty, x)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | 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
|
||||
-- root-first, this policy will find the largest subtrees for which the query
|
||||
-- holds true.
|
||||
--
|
||||
-- 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
|
||||
-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is
|
||||
-- used.
|
||||
largestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m
|
||||
largestM q f = go
|
||||
where
|
||||
go :: GenericM m
|
||||
go x = do
|
||||
case q x of
|
||||
Just (True, a) -> f a x
|
||||
Just (False, _) -> pure x
|
||||
Nothing -> gmapM go x
|
||||
|
||||
newtype MonadicQuery r m a = MonadicQuery
|
||||
{ runMonadicQuery :: m (r, a)
|
||||
}
|
||||
deriving stock (Functor)
|
||||
deriving Applicative via Compose m ((,) r)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Like 'gmapM', but also returns side-channel data.
|
||||
gmapMQ ::
|
||||
forall f r a. (Monoid r, Data a, Applicative f) =>
|
||||
(forall d. Data d => d -> f (r, d)) ->
|
||||
a ->
|
||||
f (r, a)
|
||||
gmapMQ f = runMonadicQuery . gfoldl k pure
|
||||
where
|
||||
k :: Data d => MonadicQuery r f (d -> b) -> d -> MonadicQuery r f b
|
||||
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
|
||||
// Project: http://www.flotcharts.org/
|
||||
// Definitions by: Matt Burland <https://github.com/burlandm>
|
||||
// Definitions: https://github.com/borisyankov/DefinitelyTyped
|
||||
|
||||
|
||||
declare module jquery.flot {
|
||||
interface plotOptions {
|
||||
colors?: any[];
|
||||
series?: seriesOptions;
|
||||
legend?: legendOptions;
|
||||
xaxis?: axisOptions;
|
||||
yaxis?: axisOptions;
|
||||
xaxes?: axisOptions[];
|
||||
yaxes?: axisOptions[];
|
||||
grid?: gridOptions;
|
||||
interaction?: interaction;
|
||||
hooks?: hooks;
|
||||
}
|
||||
|
||||
interface hooks {
|
||||
processOptions: { (plot: plot, options: plotOptions): void; } [];
|
||||
processRawData: { (plot: plot, series: dataSeries, data: any[], datapoints: datapoints): void; }[];
|
||||
processDatapoints: { (plot: plot, series: dataSeries, datapoints: datapoints): void; }[];
|
||||
processOffset: { (plot: plot, offset: canvasPoint): void; }[];
|
||||
drawBackground: { (plot: plot, context: CanvasRenderingContext2D): void; }[];
|
||||
drawSeries: { (plot: plot, context: CanvasRenderingContext2D, series: dataSeries): void; }[];
|
||||
draw: { (plot: plot, context: CanvasRenderingContext2D): void; }[];
|
||||
bindEvents: { (plot: plot, eventHolder: JQuery): void; }[];
|
||||
drawOverlay: { (plot: plot, context: CanvasRenderingContext2D): void; }[];
|
||||
shutdown: { (plot: plot, eventHolder: JQuery): void; }[];
|
||||
}
|
||||
|
||||
interface interaction {
|
||||
redrawOverlayInterval?: number;
|
||||
}
|
||||
|
||||
interface gridOptions {
|
||||
show?: boolean;
|
||||
aboveData?: boolean;
|
||||
color?: any; // color
|
||||
backgroundColor?: any; //color/gradient or null
|
||||
margin?: any; // number or margin object
|
||||
labelMargin?: number;
|
||||
axisMargin?: number;
|
||||
markings?: any; //array of markings or (fn: axes -> array of markings)
|
||||
borderWidth?: any; // number or width object
|
||||
borderColor?: any; // color or null
|
||||
minBorderMargin?: number; // or null
|
||||
clickable?: boolean;
|
||||
hoverable?: boolean;
|
||||
autoHighlight?: boolean;
|
||||
mouseActiveRadius?: number;
|
||||
tickColor?: any;
|
||||
markingsColor?: any;
|
||||
markingsLineWidth?: number;
|
||||
}
|
||||
|
||||
interface legendOptions {
|
||||
show?: boolean;
|
||||
labelFormatter?: (label: string, series: any) => string; // null or (fn: string, series object -> string)
|
||||
labelBoxBorderColor?: any; //color
|
||||
noColumns?: number;
|
||||
position?: string; //"ne" or "nw" or "se" or "sw"
|
||||
margin?: any; //number of pixels or [x margin, y margin]
|
||||
backgroundColor?: any; //null or color
|
||||
backgroundOpacity?: number; // between 0 and 1
|
||||
container?: JQuery; // null or jQuery object/DOM element/jQuery expression
|
||||
sorted?: any; //null/false, true, "ascending", "descending" or a comparator
|
||||
}
|
||||
|
||||
interface seriesOptions {
|
||||
color?: any; // color or number
|
||||
label?: string;
|
||||
lines?: linesOptions;
|
||||
bars?: barsOptions;
|
||||
points?: pointsOptions;
|
||||
xaxis?: number;
|
||||
yaxis?: number;
|
||||
clickable?: boolean;
|
||||
hoverable?: boolean;
|
||||
shadowSize?: number;
|
||||
highlightColor?: any;
|
||||
// Type definitions for Flot
|
||||
// Project: http://www.flotcharts.org/
|
||||
// Definitions by: Matt Burland <https://github.com/burlandm>
|
||||
// Definitions: https://github.com/borisyankov/DefinitelyTyped
|
||||
|
||||
|
||||
declare module jquery.flot {
|
||||
interface plotOptions {
|
||||
colors?: any[];
|
||||
series?: seriesOptions;
|
||||
legend?: legendOptions;
|
||||
xaxis?: axisOptions;
|
||||
yaxis?: axisOptions;
|
||||
xaxes?: axisOptions[];
|
||||
yaxes?: axisOptions[];
|
||||
grid?: gridOptions;
|
||||
interaction?: interaction;
|
||||
hooks?: hooks;
|
||||
}
|
||||
|
||||
interface hooks {
|
||||
processOptions: { (plot: plot, options: plotOptions): void; } [];
|
||||
processRawData: { (plot: plot, series: dataSeries, data: any[], datapoints: datapoints): void; }[];
|
||||
processDatapoints: { (plot: plot, series: dataSeries, datapoints: datapoints): void; }[];
|
||||
processOffset: { (plot: plot, offset: canvasPoint): void; }[];
|
||||
drawBackground: { (plot: plot, context: CanvasRenderingContext2D): void; }[];
|
||||
drawSeries: { (plot: plot, context: CanvasRenderingContext2D, series: dataSeries): void; }[];
|
||||
draw: { (plot: plot, context: CanvasRenderingContext2D): void; }[];
|
||||
bindEvents: { (plot: plot, eventHolder: JQuery): void; }[];
|
||||
drawOverlay: { (plot: plot, context: CanvasRenderingContext2D): void; }[];
|
||||
shutdown: { (plot: plot, eventHolder: JQuery): void; }[];
|
||||
}
|
||||
|
||||
interface interaction {
|
||||
redrawOverlayInterval?: number;
|
||||
}
|
||||
|
||||
interface gridOptions {
|
||||
show?: boolean;
|
||||
aboveData?: boolean;
|
||||
color?: any; // color
|
||||
backgroundColor?: any; //color/gradient or null
|
||||
margin?: any; // number or margin object
|
||||
labelMargin?: number;
|
||||
axisMargin?: number;
|
||||
markings?: any; //array of markings or (fn: axes -> array of markings)
|
||||
borderWidth?: any; // number or width object
|
||||
borderColor?: any; // color or null
|
||||
minBorderMargin?: number; // or null
|
||||
clickable?: boolean;
|
||||
hoverable?: boolean;
|
||||
autoHighlight?: boolean;
|
||||
mouseActiveRadius?: number;
|
||||
tickColor?: any;
|
||||
markingsColor?: any;
|
||||
markingsLineWidth?: number;
|
||||
}
|
||||
|
||||
interface legendOptions {
|
||||
show?: boolean;
|
||||
labelFormatter?: (label: string, series: any) => string; // null or (fn: string, series object -> string)
|
||||
labelBoxBorderColor?: any; //color
|
||||
noColumns?: number;
|
||||
position?: string; //"ne" or "nw" or "se" or "sw"
|
||||
margin?: any; //number of pixels or [x margin, y margin]
|
||||
backgroundColor?: any; //null or color
|
||||
backgroundOpacity?: number; // between 0 and 1
|
||||
container?: JQuery; // null or jQuery object/DOM element/jQuery expression
|
||||
sorted?: any; //null/false, true, "ascending", "descending" or a comparator
|
||||
}
|
||||
|
||||
interface seriesOptions {
|
||||
color?: any; // color or number
|
||||
label?: string;
|
||||
lines?: linesOptions;
|
||||
bars?: barsOptions;
|
||||
points?: pointsOptions;
|
||||
xaxis?: number;
|
||||
yaxis?: number;
|
||||
clickable?: boolean;
|
||||
hoverable?: boolean;
|
||||
shadowSize?: number;
|
||||
highlightColor?: any;
|
||||
stack?: boolean; // NEIL: Since we use the Stack plugin
|
||||
}
|
||||
|
||||
interface dataSeries extends seriesOptions {
|
||||
data: any[];
|
||||
}
|
||||
|
||||
interface axisOptions {
|
||||
show?: boolean; // null or true/false
|
||||
position?: string; // "bottom" or "top" or "left" or "right"
|
||||
|
||||
color?: any; // null or color spec
|
||||
tickColor?: any; // null or color spec
|
||||
font?: any; // null or font spec object
|
||||
|
||||
min?: number;
|
||||
max?: number;
|
||||
autoscaleMargin?: number;
|
||||
|
||||
transform?: (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)
|
||||
tickSize?: any; // number or array
|
||||
minTickSize?: any; // number or array
|
||||
tickFormatter?: (t: number, a?: axis) => string; // (fn: number, object -> string) or string
|
||||
tickDecimals?: number;
|
||||
|
||||
labelWidth?: number;
|
||||
labelHeight?: number;
|
||||
reserveSpace?: boolean;
|
||||
|
||||
tickLength?: number;
|
||||
|
||||
alignTicksWithAxis?: number;
|
||||
}
|
||||
|
||||
interface seriesTypeBase {
|
||||
show?: boolean;
|
||||
lineWidth?: number;
|
||||
fill?: any; //boolean or number
|
||||
fillColor?: any; //null or color/gradient
|
||||
}
|
||||
|
||||
interface linesOptions extends seriesTypeBase {
|
||||
steps?: boolean;
|
||||
}
|
||||
|
||||
interface barsOptions extends seriesTypeBase {
|
||||
barWidth?: number;
|
||||
align?: string;
|
||||
horizontal?: boolean;
|
||||
}
|
||||
|
||||
interface pointsOptions extends seriesTypeBase {
|
||||
radius?: number;
|
||||
symbol?: any;
|
||||
}
|
||||
|
||||
interface gradient {
|
||||
colors: any[];
|
||||
}
|
||||
|
||||
interface item {
|
||||
datapoint: number[]; // the point, e.g. [0, 2]
|
||||
dataIndex: number; // the index of the point in the data array
|
||||
series: dataSeries; //the series object
|
||||
seriesIndex: number; //the index of the series
|
||||
pageX: number;
|
||||
pageY: number; //the global screen coordinates of the point
|
||||
}
|
||||
|
||||
interface datapoints {
|
||||
points: number[];
|
||||
pointsize: number;
|
||||
format: datapointFormat[];
|
||||
}
|
||||
|
||||
interface datapointFormat {
|
||||
x?: boolean;
|
||||
y?: boolean;
|
||||
number: boolean;
|
||||
required: boolean;
|
||||
defaultValue?: number;
|
||||
}
|
||||
|
||||
interface point {
|
||||
x: number;
|
||||
y: number;
|
||||
}
|
||||
|
||||
interface offset {
|
||||
left: number;
|
||||
top: number;
|
||||
}
|
||||
|
||||
interface canvasPoint {
|
||||
top: number;
|
||||
left: number;
|
||||
bottom?: number;
|
||||
right?: number;
|
||||
}
|
||||
|
||||
interface axes {
|
||||
xaxis: axis;
|
||||
yaxis: axis;
|
||||
x2axis?: axis;
|
||||
y2axis?: axis;
|
||||
}
|
||||
|
||||
interface axis extends axisOptions {
|
||||
options: axisOptions;
|
||||
p2c(point: point):canvasPoint;
|
||||
c2p(canvasPoint: canvasPoint):point;
|
||||
}
|
||||
|
||||
interface plugin {
|
||||
init(options: plotOptions): any;
|
||||
options?: any;
|
||||
name?: string;
|
||||
version?: string;
|
||||
}
|
||||
|
||||
interface plot {
|
||||
highlight(series: dataSeries, datapoint: item): void;
|
||||
unhighlight(): void;
|
||||
unhighlight(series: dataSeries, datapoint: item): void;
|
||||
setData(data: any): void;
|
||||
setupGrid(): void;
|
||||
draw(): void;
|
||||
triggerRedrawOverlay(): void;
|
||||
width(): number;
|
||||
height(): number;
|
||||
offset(): JQueryCoordinates;
|
||||
pointOffset(point: point): offset;
|
||||
resize(): void;
|
||||
shutdown(): void;
|
||||
getData(): dataSeries[];
|
||||
getAxes(): axes;
|
||||
getXAxes(): axis[];
|
||||
getYAxes(): axis[];
|
||||
getPlaceholder(): JQuery;
|
||||
getCanvas(): HTMLCanvasElement;
|
||||
getPlotOffset(): canvasPoint;
|
||||
getOptions(): plotOptions;
|
||||
}
|
||||
|
||||
interface plotStatic {
|
||||
(placeholder: JQuery, data: dataSeries[], options?: plotOptions): plot;
|
||||
(placeholder: JQuery, data: any[], options?: plotOptions): plot;
|
||||
plugins: plugin[];
|
||||
}
|
||||
}
|
||||
|
||||
interface JQueryStatic {
|
||||
plot: jquery.flot.plotStatic;
|
||||
}
|
||||
}
|
||||
|
||||
interface dataSeries extends seriesOptions {
|
||||
data: any[];
|
||||
}
|
||||
|
||||
interface axisOptions {
|
||||
show?: boolean; // null or true/false
|
||||
position?: string; // "bottom" or "top" or "left" or "right"
|
||||
|
||||
color?: any; // null or color spec
|
||||
tickColor?: any; // null or color spec
|
||||
font?: any; // null or font spec object
|
||||
|
||||
min?: number;
|
||||
max?: number;
|
||||
autoscaleMargin?: number;
|
||||
|
||||
transform?: (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)
|
||||
tickSize?: any; // number or array
|
||||
minTickSize?: any; // number or array
|
||||
tickFormatter?: (t: number, a?: axis) => string; // (fn: number, object -> string) or string
|
||||
tickDecimals?: number;
|
||||
|
||||
labelWidth?: number;
|
||||
labelHeight?: number;
|
||||
reserveSpace?: boolean;
|
||||
|
||||
tickLength?: number;
|
||||
|
||||
alignTicksWithAxis?: number;
|
||||
}
|
||||
|
||||
interface seriesTypeBase {
|
||||
show?: boolean;
|
||||
lineWidth?: number;
|
||||
fill?: any; //boolean or number
|
||||
fillColor?: any; //null or color/gradient
|
||||
}
|
||||
|
||||
interface linesOptions extends seriesTypeBase {
|
||||
steps?: boolean;
|
||||
}
|
||||
|
||||
interface barsOptions extends seriesTypeBase {
|
||||
barWidth?: number;
|
||||
align?: string;
|
||||
horizontal?: boolean;
|
||||
}
|
||||
|
||||
interface pointsOptions extends seriesTypeBase {
|
||||
radius?: number;
|
||||
symbol?: any;
|
||||
}
|
||||
|
||||
interface gradient {
|
||||
colors: any[];
|
||||
}
|
||||
|
||||
interface item {
|
||||
datapoint: number[]; // the point, e.g. [0, 2]
|
||||
dataIndex: number; // the index of the point in the data array
|
||||
series: dataSeries; //the series object
|
||||
seriesIndex: number; //the index of the series
|
||||
pageX: number;
|
||||
pageY: number; //the global screen coordinates of the point
|
||||
}
|
||||
|
||||
interface datapoints {
|
||||
points: number[];
|
||||
pointsize: number;
|
||||
format: datapointFormat[];
|
||||
}
|
||||
|
||||
interface datapointFormat {
|
||||
x?: boolean;
|
||||
y?: boolean;
|
||||
number: boolean;
|
||||
required: boolean;
|
||||
defaultValue?: number;
|
||||
}
|
||||
|
||||
interface point {
|
||||
x: number;
|
||||
y: number;
|
||||
}
|
||||
|
||||
interface offset {
|
||||
left: number;
|
||||
top: number;
|
||||
}
|
||||
|
||||
interface canvasPoint {
|
||||
top: number;
|
||||
left: number;
|
||||
bottom?: number;
|
||||
right?: number;
|
||||
}
|
||||
|
||||
interface axes {
|
||||
xaxis: axis;
|
||||
yaxis: axis;
|
||||
x2axis?: axis;
|
||||
y2axis?: axis;
|
||||
}
|
||||
|
||||
interface axis extends axisOptions {
|
||||
options: axisOptions;
|
||||
p2c(point: point):canvasPoint;
|
||||
c2p(canvasPoint: canvasPoint):point;
|
||||
}
|
||||
|
||||
interface plugin {
|
||||
init(options: plotOptions): any;
|
||||
options?: any;
|
||||
name?: string;
|
||||
version?: string;
|
||||
}
|
||||
|
||||
interface plot {
|
||||
highlight(series: dataSeries, datapoint: item): void;
|
||||
unhighlight(): void;
|
||||
unhighlight(series: dataSeries, datapoint: item): void;
|
||||
setData(data: any): void;
|
||||
setupGrid(): void;
|
||||
draw(): void;
|
||||
triggerRedrawOverlay(): void;
|
||||
width(): number;
|
||||
height(): number;
|
||||
offset(): JQueryCoordinates;
|
||||
pointOffset(point: point): offset;
|
||||
resize(): void;
|
||||
shutdown(): void;
|
||||
getData(): dataSeries[];
|
||||
getAxes(): axes;
|
||||
getXAxes(): axis[];
|
||||
getYAxes(): axis[];
|
||||
getPlaceholder(): JQuery;
|
||||
getCanvas(): HTMLCanvasElement;
|
||||
getPlotOffset(): canvasPoint;
|
||||
getOptions(): plotOptions;
|
||||
}
|
||||
|
||||
interface plotStatic {
|
||||
(placeholder: JQuery, data: dataSeries[], options?: plotOptions): plot;
|
||||
(placeholder: JQuery, data: any[], options?: plotOptions): plot;
|
||||
plugins: plugin[];
|
||||
}
|
||||
}
|
||||
|
||||
interface JQueryStatic {
|
||||
plot: jquery.flot.plotStatic;
|
||||
}
|
||||
|
||||
@ -1,8 +1,8 @@
|
||||
|
||||
module Development.IDE.Graph.Classes(
|
||||
Show(..), Typeable, Eq(..), Hashable(..), NFData(..)
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Data.Hashable
|
||||
import Data.Typeable
|
||||
|
||||
module Development.IDE.Graph.Classes(
|
||||
Show(..), Typeable, Eq(..), Hashable(..), NFData(..)
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Data.Hashable
|
||||
import Data.Typeable
|
||||
|
||||
@ -1,137 +1,137 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Development.IDE.Graph.Internal.Action
|
||||
( ShakeValue
|
||||
, actionFork
|
||||
, actionBracket
|
||||
, actionCatch
|
||||
, actionFinally
|
||||
, alwaysRerun
|
||||
, apply1
|
||||
, apply
|
||||
, parallel
|
||||
, reschedule
|
||||
, runActions
|
||||
, Development.IDE.Graph.Internal.Action.getDirtySet
|
||||
, getKeysAndVisitedAge
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Async
|
||||
import Control.Exception
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.IORef
|
||||
import Development.IDE.Graph.Classes
|
||||
import Development.IDE.Graph.Internal.Database
|
||||
import Development.IDE.Graph.Internal.Rules (RuleResult)
|
||||
import Development.IDE.Graph.Internal.Types
|
||||
import System.Exit
|
||||
|
||||
type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
|
||||
|
||||
-- | Always rerun this rule when dirty, regardless of the dependencies.
|
||||
alwaysRerun :: Action ()
|
||||
alwaysRerun = do
|
||||
ref <- Action $ asks actionDeps
|
||||
liftIO $ modifyIORef ref (AlwaysRerunDeps [] <>)
|
||||
|
||||
-- No-op for now
|
||||
reschedule :: Double -> Action ()
|
||||
reschedule _ = pure ()
|
||||
|
||||
parallel :: [Action a] -> Action [a]
|
||||
parallel [] = pure []
|
||||
parallel [x] = fmap (:[]) x
|
||||
parallel xs = do
|
||||
a <- Action ask
|
||||
deps <- liftIO $ readIORef $ actionDeps a
|
||||
case deps of
|
||||
UnknownDeps ->
|
||||
-- if we are already in the rerun mode, nothing we do is going to impact our state
|
||||
liftIO $ mapConcurrently (ignoreState a) xs
|
||||
deps -> do
|
||||
(newDeps, res) <- liftIO $ unzip <$> mapConcurrently (usingState a) xs
|
||||
liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps
|
||||
pure res
|
||||
where
|
||||
usingState a x = do
|
||||
ref <- newIORef mempty
|
||||
res <- runReaderT (fromAction x) a{actionDeps=ref}
|
||||
deps <- readIORef ref
|
||||
pure (deps, res)
|
||||
|
||||
ignoreState :: SAction -> Action b -> IO b
|
||||
ignoreState a x = do
|
||||
ref <- newIORef mempty
|
||||
runReaderT (fromAction x) a{actionDeps=ref}
|
||||
|
||||
actionFork :: Action a -> (Async a -> Action b) -> Action b
|
||||
actionFork act k = do
|
||||
a <- Action ask
|
||||
deps <- liftIO $ readIORef $ actionDeps a
|
||||
let db = actionDatabase a
|
||||
case deps of
|
||||
UnknownDeps -> do
|
||||
-- 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]
|
||||
return res
|
||||
_ ->
|
||||
error "please help me"
|
||||
|
||||
isAsyncException :: SomeException -> Bool
|
||||
isAsyncException e
|
||||
| Just (_ :: AsyncCancelled) <- fromException e = True
|
||||
| Just (_ :: AsyncException) <- fromException e = True
|
||||
| Just (_ :: ExitCode) <- fromException e = True
|
||||
| otherwise = False
|
||||
|
||||
|
||||
actionCatch :: Exception e => Action a -> (e -> Action a) -> Action a
|
||||
actionCatch a b = do
|
||||
v <- Action ask
|
||||
Action $ lift $ catchJust f (runReaderT (fromAction a) v) (\x -> runReaderT (fromAction (b x)) v)
|
||||
where
|
||||
-- Catch only catches exceptions that were caused by this code, not those that
|
||||
-- are a result of program termination
|
||||
f e | isAsyncException e = Nothing
|
||||
| otherwise = fromException e
|
||||
|
||||
actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c
|
||||
actionBracket a b c = do
|
||||
v <- Action ask
|
||||
Action $ lift $ bracket a b (\x -> runReaderT (fromAction (c x)) v)
|
||||
|
||||
actionFinally :: Action a -> IO b -> Action a
|
||||
actionFinally a b = do
|
||||
v <- Action ask
|
||||
Action $ lift $ finally (runReaderT (fromAction a) v) b
|
||||
|
||||
apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value
|
||||
apply1 k = head <$> apply [k]
|
||||
|
||||
apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value]
|
||||
apply ks = do
|
||||
db <- Action $ asks actionDatabase
|
||||
(is, vs) <- liftIO $ build db ks
|
||||
ref <- Action $ asks actionDeps
|
||||
liftIO $ modifyIORef ref (ResultDeps is <>)
|
||||
pure vs
|
||||
|
||||
runActions :: Database -> [Action a] -> IO [a]
|
||||
runActions db xs = do
|
||||
deps <- newIORef mempty
|
||||
runReaderT (fromAction $ parallel xs) $ SAction db deps
|
||||
|
||||
-- | Returns the set of dirty keys annotated with their age (in # of builds)
|
||||
getDirtySet :: Action [(Key, Int)]
|
||||
getDirtySet = do
|
||||
db <- getDatabase
|
||||
liftIO $ Development.IDE.Graph.Internal.Database.getDirtySet db
|
||||
|
||||
getKeysAndVisitedAge :: Action [(Key, Int)]
|
||||
getKeysAndVisitedAge = do
|
||||
db <- getDatabase
|
||||
liftIO $ Development.IDE.Graph.Internal.Database.getKeysAndVisitAge db
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Development.IDE.Graph.Internal.Action
|
||||
( ShakeValue
|
||||
, actionFork
|
||||
, actionBracket
|
||||
, actionCatch
|
||||
, actionFinally
|
||||
, alwaysRerun
|
||||
, apply1
|
||||
, apply
|
||||
, parallel
|
||||
, reschedule
|
||||
, runActions
|
||||
, Development.IDE.Graph.Internal.Action.getDirtySet
|
||||
, getKeysAndVisitedAge
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Async
|
||||
import Control.Exception
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.IORef
|
||||
import Development.IDE.Graph.Classes
|
||||
import Development.IDE.Graph.Internal.Database
|
||||
import Development.IDE.Graph.Internal.Rules (RuleResult)
|
||||
import Development.IDE.Graph.Internal.Types
|
||||
import System.Exit
|
||||
|
||||
type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
|
||||
|
||||
-- | Always rerun this rule when dirty, regardless of the dependencies.
|
||||
alwaysRerun :: Action ()
|
||||
alwaysRerun = do
|
||||
ref <- Action $ asks actionDeps
|
||||
liftIO $ modifyIORef ref (AlwaysRerunDeps [] <>)
|
||||
|
||||
-- No-op for now
|
||||
reschedule :: Double -> Action ()
|
||||
reschedule _ = pure ()
|
||||
|
||||
parallel :: [Action a] -> Action [a]
|
||||
parallel [] = pure []
|
||||
parallel [x] = fmap (:[]) x
|
||||
parallel xs = do
|
||||
a <- Action ask
|
||||
deps <- liftIO $ readIORef $ actionDeps a
|
||||
case deps of
|
||||
UnknownDeps ->
|
||||
-- if we are already in the rerun mode, nothing we do is going to impact our state
|
||||
liftIO $ mapConcurrently (ignoreState a) xs
|
||||
deps -> do
|
||||
(newDeps, res) <- liftIO $ unzip <$> mapConcurrently (usingState a) xs
|
||||
liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps
|
||||
pure res
|
||||
where
|
||||
usingState a x = do
|
||||
ref <- newIORef mempty
|
||||
res <- runReaderT (fromAction x) a{actionDeps=ref}
|
||||
deps <- readIORef ref
|
||||
pure (deps, res)
|
||||
|
||||
ignoreState :: SAction -> Action b -> IO b
|
||||
ignoreState a x = do
|
||||
ref <- newIORef mempty
|
||||
runReaderT (fromAction x) a{actionDeps=ref}
|
||||
|
||||
actionFork :: Action a -> (Async a -> Action b) -> Action b
|
||||
actionFork act k = do
|
||||
a <- Action ask
|
||||
deps <- liftIO $ readIORef $ actionDeps a
|
||||
let db = actionDatabase a
|
||||
case deps of
|
||||
UnknownDeps -> do
|
||||
-- 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]
|
||||
return res
|
||||
_ ->
|
||||
error "please help me"
|
||||
|
||||
isAsyncException :: SomeException -> Bool
|
||||
isAsyncException e
|
||||
| Just (_ :: AsyncCancelled) <- fromException e = True
|
||||
| Just (_ :: AsyncException) <- fromException e = True
|
||||
| Just (_ :: ExitCode) <- fromException e = True
|
||||
| otherwise = False
|
||||
|
||||
|
||||
actionCatch :: Exception e => Action a -> (e -> Action a) -> Action a
|
||||
actionCatch a b = do
|
||||
v <- Action ask
|
||||
Action $ lift $ catchJust f (runReaderT (fromAction a) v) (\x -> runReaderT (fromAction (b x)) v)
|
||||
where
|
||||
-- Catch only catches exceptions that were caused by this code, not those that
|
||||
-- are a result of program termination
|
||||
f e | isAsyncException e = Nothing
|
||||
| otherwise = fromException e
|
||||
|
||||
actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c
|
||||
actionBracket a b c = do
|
||||
v <- Action ask
|
||||
Action $ lift $ bracket a b (\x -> runReaderT (fromAction (c x)) v)
|
||||
|
||||
actionFinally :: Action a -> IO b -> Action a
|
||||
actionFinally a b = do
|
||||
v <- Action ask
|
||||
Action $ lift $ finally (runReaderT (fromAction a) v) b
|
||||
|
||||
apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value
|
||||
apply1 k = head <$> apply [k]
|
||||
|
||||
apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value]
|
||||
apply ks = do
|
||||
db <- Action $ asks actionDatabase
|
||||
(is, vs) <- liftIO $ build db ks
|
||||
ref <- Action $ asks actionDeps
|
||||
liftIO $ modifyIORef ref (ResultDeps is <>)
|
||||
pure vs
|
||||
|
||||
runActions :: Database -> [Action a] -> IO [a]
|
||||
runActions db xs = do
|
||||
deps <- newIORef mempty
|
||||
runReaderT (fromAction $ parallel xs) $ SAction db deps
|
||||
|
||||
-- | Returns the set of dirty keys annotated with their age (in # of builds)
|
||||
getDirtySet :: Action [(Key, Int)]
|
||||
getDirtySet = do
|
||||
db <- getDatabase
|
||||
liftIO $ Development.IDE.Graph.Internal.Database.getDirtySet db
|
||||
|
||||
getKeysAndVisitedAge :: Action [(Key, Int)]
|
||||
getKeysAndVisitedAge = do
|
||||
db <- getDatabase
|
||||
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
|
||||
-- has the constraints we need on it when we get it out.
|
||||
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Development.IDE.Graph.Internal.Rules where
|
||||
|
||||
import Control.Exception.Extra
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Reader
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Dynamic
|
||||
import qualified Data.HashMap.Strict as Map
|
||||
import Data.IORef
|
||||
import Data.Maybe
|
||||
import Data.Typeable
|
||||
import Development.IDE.Graph.Classes
|
||||
import Development.IDE.Graph.Internal.Types
|
||||
|
||||
-- | The type mapping between the @key@ or a rule and the resulting @value@.
|
||||
-- See 'addBuiltinRule' and 'Development.Shake.Rule.apply'.
|
||||
type family RuleResult key -- = value
|
||||
|
||||
action :: Action a -> Rules ()
|
||||
action x = do
|
||||
ref <- Rules $ asks rulesActions
|
||||
liftIO $ modifyIORef' ref (void x:)
|
||||
|
||||
addRule
|
||||
:: forall key value .
|
||||
(RuleResult key ~ value, Typeable key, Hashable key, Eq key, Typeable value)
|
||||
=> (key -> Maybe BS.ByteString -> RunMode -> Action (RunResult value))
|
||||
-> Rules ()
|
||||
addRule f = do
|
||||
ref <- Rules $ asks rulesMap
|
||||
liftIO $ modifyIORef' ref $ Map.insert (typeRep (Proxy :: Proxy key)) (toDyn f2)
|
||||
where
|
||||
f2 :: Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value)
|
||||
f2 (Key a) b c = do
|
||||
v <- f (fromJust $ cast a :: key) b c
|
||||
v <- liftIO $ evaluate v
|
||||
pure $ Value . toDyn <$> v
|
||||
|
||||
runRule
|
||||
:: TheRules -> Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value)
|
||||
runRule rules key@(Key t) bs mode = case Map.lookup (typeOf t) rules of
|
||||
Nothing -> liftIO $ errorIO "Could not find key"
|
||||
Just x -> unwrapDynamic x key bs mode
|
||||
|
||||
runRules :: Dynamic -> Rules () -> IO (TheRules, [Action ()])
|
||||
runRules rulesExtra (Rules rules) = do
|
||||
rulesActions <- newIORef []
|
||||
rulesMap <- newIORef Map.empty
|
||||
runReaderT rules SRules{..}
|
||||
(,) <$> readIORef rulesMap <*> readIORef rulesActions
|
||||
-- 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.
|
||||
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Development.IDE.Graph.Internal.Rules where
|
||||
|
||||
import Control.Exception.Extra
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Reader
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Dynamic
|
||||
import qualified Data.HashMap.Strict as Map
|
||||
import Data.IORef
|
||||
import Data.Maybe
|
||||
import Data.Typeable
|
||||
import Development.IDE.Graph.Classes
|
||||
import Development.IDE.Graph.Internal.Types
|
||||
|
||||
-- | The type mapping between the @key@ or a rule and the resulting @value@.
|
||||
-- See 'addBuiltinRule' and 'Development.Shake.Rule.apply'.
|
||||
type family RuleResult key -- = value
|
||||
|
||||
action :: Action a -> Rules ()
|
||||
action x = do
|
||||
ref <- Rules $ asks rulesActions
|
||||
liftIO $ modifyIORef' ref (void x:)
|
||||
|
||||
addRule
|
||||
:: forall key value .
|
||||
(RuleResult key ~ value, Typeable key, Hashable key, Eq key, Typeable value)
|
||||
=> (key -> Maybe BS.ByteString -> RunMode -> Action (RunResult value))
|
||||
-> Rules ()
|
||||
addRule f = do
|
||||
ref <- Rules $ asks rulesMap
|
||||
liftIO $ modifyIORef' ref $ Map.insert (typeRep (Proxy :: Proxy key)) (toDyn f2)
|
||||
where
|
||||
f2 :: Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value)
|
||||
f2 (Key a) b c = do
|
||||
v <- f (fromJust $ cast a :: key) b c
|
||||
v <- liftIO $ evaluate v
|
||||
pure $ Value . toDyn <$> v
|
||||
|
||||
runRule
|
||||
:: TheRules -> Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value)
|
||||
runRule rules key@(Key t) bs mode = case Map.lookup (typeOf t) rules of
|
||||
Nothing -> liftIO $ errorIO "Could not find key"
|
||||
Just x -> unwrapDynamic x key bs mode
|
||||
|
||||
runRules :: Dynamic -> Rules () -> IO (TheRules, [Action ()])
|
||||
runRules rulesExtra (Rules rules) = do
|
||||
rulesActions <- newIORef []
|
||||
rulesMap <- newIORef Map.empty
|
||||
runReaderT rules SRules{..}
|
||||
(,) <$> readIORef rulesMap <*> readIORef rulesActions
|
||||
|
||||
@ -1,12 +1,12 @@
|
||||
-- | Fake cabal module for local building
|
||||
|
||||
module Paths_hls_graph(getDataDir, version) where
|
||||
|
||||
import Data.Version.Extra
|
||||
|
||||
-- If hls_graph can't find files in the data directory it tries relative to the executable
|
||||
getDataDir :: IO FilePath
|
||||
getDataDir = pure "random_path_that_cannot_possibly_exist"
|
||||
|
||||
version :: Version
|
||||
version = makeVersion [0,0]
|
||||
-- | Fake cabal module for local building
|
||||
|
||||
module Paths_hls_graph(getDataDir, version) where
|
||||
|
||||
import Data.Version.Extra
|
||||
|
||||
-- If hls_graph can't find files in the data directory it tries relative to the executable
|
||||
getDataDir :: IO FilePath
|
||||
getDataDir = pure "random_path_that_cannot_possibly_exist"
|
||||
|
||||
version :: Version
|
||||
version = makeVersion [0,0]
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,20 +1,20 @@
|
||||
module InfoUtil
|
||||
( Eq
|
||||
, Ord
|
||||
, Foo (..)
|
||||
, Bar (..)
|
||||
, Baz
|
||||
)
|
||||
where
|
||||
|
||||
import Prelude (Eq, Ord)
|
||||
|
||||
data Foo = Foo1 | Foo2
|
||||
deriving (Eq, Ord)
|
||||
|
||||
data Bar = Bar1 | Bar2 | Bar3
|
||||
deriving (Eq, Ord)
|
||||
|
||||
class Baz t
|
||||
instance Baz Foo
|
||||
instance Baz Bar
|
||||
module InfoUtil
|
||||
( Eq
|
||||
, Ord
|
||||
, Foo (..)
|
||||
, Bar (..)
|
||||
, Baz
|
||||
)
|
||||
where
|
||||
|
||||
import Prelude (Eq, Ord)
|
||||
|
||||
data Foo = Foo1 | Foo2
|
||||
deriving (Eq, Ord)
|
||||
|
||||
data Bar = Bar1 | Bar2 | Bar3
|
||||
deriving (Eq, Ord)
|
||||
|
||||
class Baz t
|
||||
instance Baz Foo
|
||||
instance Baz Bar
|
||||
|
||||
@ -32,9 +32,9 @@ import Data.Aeson (FromJSON (..),
|
||||
Value (Null),
|
||||
genericParseJSON)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Bifunctor (Bifunctor (first),
|
||||
second)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Coerce
|
||||
import Data.Either (partitionEithers)
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
|
||||
@ -1,79 +1,79 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Ide.Plugin.StylishHaskell
|
||||
( descriptor
|
||||
, provider
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE hiding (pluginHandlers)
|
||||
import Development.IDE.GHC.Compat (ModSummary (ms_hspp_opts),
|
||||
extensionFlags)
|
||||
import qualified Development.IDE.GHC.Compat.Util as Util
|
||||
import GHC.LanguageExtensions.Type
|
||||
import Ide.PluginUtils
|
||||
import Ide.Types
|
||||
import Language.Haskell.Stylish
|
||||
import Language.LSP.Types as J
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
|
||||
descriptor :: PluginId -> PluginDescriptor IdeState
|
||||
descriptor plId = (defaultPluginDescriptor plId)
|
||||
{ pluginHandlers = mkFormattingHandlers provider
|
||||
}
|
||||
|
||||
-- | Formatter provider of stylish-haskell.
|
||||
-- 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.
|
||||
provider :: FormattingHandler IdeState
|
||||
provider ide typ contents fp _opts = do
|
||||
dyn <- fmap (ms_hspp_opts . msrModSummary) $ liftIO $ runAction "stylish-haskell" ide $ use_ GetModSummary fp
|
||||
let file = fromNormalizedFilePath fp
|
||||
config <- liftIO $ loadConfigFrom file
|
||||
mergedConfig <- liftIO $ getMergedConfig dyn config
|
||||
let (range, selectedContents) = case typ of
|
||||
FormatText -> (fullRange contents, contents)
|
||||
FormatRange r -> (normalize r, extractRange r contents)
|
||||
result = runStylishHaskell file mergedConfig selectedContents
|
||||
case result of
|
||||
Left err -> return $ Left $ responseError $ T.pack $ "stylishHaskellCmd: " ++ err
|
||||
Right new -> return $ Right $ J.List [TextEdit range new]
|
||||
where
|
||||
getMergedConfig dyn config
|
||||
| null (configLanguageExtensions config)
|
||||
= do
|
||||
logInfo (ideLogger ide) "stylish-haskell uses the language extensions from DynFlags"
|
||||
pure
|
||||
$ config
|
||||
{ configLanguageExtensions = getExtensions dyn }
|
||||
| otherwise
|
||||
= pure config
|
||||
|
||||
getExtensions = map showExtension . Util.toList . extensionFlags
|
||||
|
||||
showExtension Cpp = "CPP"
|
||||
showExtension other = show other
|
||||
|
||||
-- | Recursively search in every directory of the given filepath for .stylish-haskell.yaml.
|
||||
-- If no such file has been found, return default config.
|
||||
loadConfigFrom :: FilePath -> IO Config
|
||||
loadConfigFrom file = do
|
||||
currDir <- getCurrentDirectory
|
||||
setCurrentDirectory (takeDirectory file)
|
||||
config <- loadConfig (makeVerbose False) Nothing
|
||||
setCurrentDirectory currDir
|
||||
pure config
|
||||
|
||||
-- | Run stylish-haskell on the given text with the given configuration.
|
||||
runStylishHaskell :: FilePath -- ^ Location of the file being formatted. Used for error message
|
||||
-> Config -- ^ Configuration for stylish-haskell
|
||||
-> Text -- ^ Text to format
|
||||
-> Either String Text -- ^ Either formatted Text or an error message
|
||||
runStylishHaskell file config = fmap fromLines . fmt . toLines
|
||||
where
|
||||
fromLines = T.pack . unlines
|
||||
fmt = runSteps (configLanguageExtensions config) (Just file) (configSteps config)
|
||||
toLines = lines . T.unpack
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Ide.Plugin.StylishHaskell
|
||||
( descriptor
|
||||
, provider
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE hiding (pluginHandlers)
|
||||
import Development.IDE.GHC.Compat (ModSummary (ms_hspp_opts),
|
||||
extensionFlags)
|
||||
import qualified Development.IDE.GHC.Compat.Util as Util
|
||||
import GHC.LanguageExtensions.Type
|
||||
import Ide.PluginUtils
|
||||
import Ide.Types
|
||||
import Language.Haskell.Stylish
|
||||
import Language.LSP.Types as J
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
|
||||
descriptor :: PluginId -> PluginDescriptor IdeState
|
||||
descriptor plId = (defaultPluginDescriptor plId)
|
||||
{ pluginHandlers = mkFormattingHandlers provider
|
||||
}
|
||||
|
||||
-- | Formatter provider of stylish-haskell.
|
||||
-- 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.
|
||||
provider :: FormattingHandler IdeState
|
||||
provider ide typ contents fp _opts = do
|
||||
dyn <- fmap (ms_hspp_opts . msrModSummary) $ liftIO $ runAction "stylish-haskell" ide $ use_ GetModSummary fp
|
||||
let file = fromNormalizedFilePath fp
|
||||
config <- liftIO $ loadConfigFrom file
|
||||
mergedConfig <- liftIO $ getMergedConfig dyn config
|
||||
let (range, selectedContents) = case typ of
|
||||
FormatText -> (fullRange contents, contents)
|
||||
FormatRange r -> (normalize r, extractRange r contents)
|
||||
result = runStylishHaskell file mergedConfig selectedContents
|
||||
case result of
|
||||
Left err -> return $ Left $ responseError $ T.pack $ "stylishHaskellCmd: " ++ err
|
||||
Right new -> return $ Right $ J.List [TextEdit range new]
|
||||
where
|
||||
getMergedConfig dyn config
|
||||
| null (configLanguageExtensions config)
|
||||
= do
|
||||
logInfo (ideLogger ide) "stylish-haskell uses the language extensions from DynFlags"
|
||||
pure
|
||||
$ config
|
||||
{ configLanguageExtensions = getExtensions dyn }
|
||||
| otherwise
|
||||
= pure config
|
||||
|
||||
getExtensions = map showExtension . Util.toList . extensionFlags
|
||||
|
||||
showExtension Cpp = "CPP"
|
||||
showExtension other = show other
|
||||
|
||||
-- | Recursively search in every directory of the given filepath for .stylish-haskell.yaml.
|
||||
-- If no such file has been found, return default config.
|
||||
loadConfigFrom :: FilePath -> IO Config
|
||||
loadConfigFrom file = do
|
||||
currDir <- getCurrentDirectory
|
||||
setCurrentDirectory (takeDirectory file)
|
||||
config <- loadConfig (makeVerbose False) Nothing
|
||||
setCurrentDirectory currDir
|
||||
pure config
|
||||
|
||||
-- | Run stylish-haskell on the given text with the given configuration.
|
||||
runStylishHaskell :: FilePath -- ^ Location of the file being formatted. Used for error message
|
||||
-> Config -- ^ Configuration for stylish-haskell
|
||||
-> Text -- ^ Text to format
|
||||
-> Either String Text -- ^ Either formatted Text or an error message
|
||||
runStylishHaskell file config = fmap fromLines . fmt . toLines
|
||||
where
|
||||
fromLines = T.pack . unlines
|
||||
fmt = runSteps (configLanguageExtensions config) (Just file) (configSteps config)
|
||||
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.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
|
||||
|
||||
module Ide.Arguments
|
||||
( Arguments(..)
|
||||
, GhcideArguments(..)
|
||||
, PrintVersion(..)
|
||||
, BiosAction(..)
|
||||
, getArguments
|
||||
, haskellLanguageServerVersion
|
||||
, haskellLanguageServerNumericVersion
|
||||
) where
|
||||
|
||||
import Data.Version
|
||||
import Development.IDE (IdeState)
|
||||
import Development.IDE.Main (Command (..), commandP)
|
||||
import GitHash (giHash, tGitInfoCwdTry)
|
||||
import Ide.Types (IdePlugins)
|
||||
import Options.Applicative
|
||||
import Paths_haskell_language_server
|
||||
import System.Environment
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
data Arguments
|
||||
= VersionMode PrintVersion
|
||||
| ProbeToolsMode
|
||||
| ListPluginsMode
|
||||
| BiosMode BiosAction
|
||||
| Ghcide GhcideArguments
|
||||
| VSCodeExtensionSchemaMode
|
||||
| DefaultConfigurationMode
|
||||
|
||||
data GhcideArguments = GhcideArguments
|
||||
{argsCommand :: Command
|
||||
,argsCwd :: Maybe FilePath
|
||||
,argsShakeProfiling :: Maybe FilePath
|
||||
,argsTesting :: Bool
|
||||
,argsExamplePlugin :: Bool
|
||||
-- These next two are for compatibility with existing hie clients, allowing
|
||||
-- them to just change the name of the exe and still work.
|
||||
, argsDebugOn :: Bool
|
||||
, argsLogFile :: Maybe String
|
||||
, argsThreads :: Int
|
||||
, argsProjectGhcVersion :: Bool
|
||||
} deriving Show
|
||||
|
||||
data PrintVersion
|
||||
= PrintVersion
|
||||
| PrintNumericVersion
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data BiosAction
|
||||
= PrintCradleType
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
getArguments :: String -> IdePlugins IdeState -> IO Arguments
|
||||
getArguments exeName plugins = execParser opts
|
||||
where
|
||||
opts = info ((
|
||||
VersionMode <$> printVersionParser exeName
|
||||
<|> probeToolsParser exeName
|
||||
<|> listPluginsParser
|
||||
<|> BiosMode <$> biosParser
|
||||
<|> Ghcide <$> arguments plugins
|
||||
)
|
||||
<**> helper)
|
||||
( fullDesc
|
||||
<> progDesc "Used as a test bed to check your IDE Client will work"
|
||||
<> header (exeName ++ " - GHC Haskell LSP server"))
|
||||
|
||||
printVersionParser :: String -> Parser PrintVersion
|
||||
printVersionParser exeName =
|
||||
flag' PrintVersion
|
||||
(long "version" <> help ("Show " ++ exeName ++ " and GHC versions"))
|
||||
<|>
|
||||
flag' PrintNumericVersion
|
||||
(long "numeric-version" <> help ("Show numeric version of " ++ exeName))
|
||||
|
||||
biosParser :: Parser BiosAction
|
||||
biosParser =
|
||||
flag' PrintCradleType
|
||||
(long "print-cradle" <> help "Print the project cradle type")
|
||||
|
||||
probeToolsParser :: String -> Parser Arguments
|
||||
probeToolsParser exeName =
|
||||
flag' ProbeToolsMode
|
||||
(long "probe-tools" <> help ("Show " ++ exeName ++ " version and other tools of interest"))
|
||||
|
||||
listPluginsParser :: Parser Arguments
|
||||
listPluginsParser =
|
||||
flag' ListPluginsMode
|
||||
(long "list-plugins" <> help "List all available plugins")
|
||||
|
||||
arguments :: IdePlugins IdeState -> Parser GhcideArguments
|
||||
arguments plugins = GhcideArguments
|
||||
<$> (commandP plugins <|> lspCommand <|> checkCommand)
|
||||
<*> optional (strOption $ long "cwd" <> metavar "DIR"
|
||||
<> help "Change to this directory")
|
||||
<*> optional (strOption $ long "shake-profiling" <> metavar "DIR"
|
||||
<> help "Dump profiling reports to this directory")
|
||||
<*> switch (long "test"
|
||||
<> help "Enable additional lsp messages used by the testsuite")
|
||||
<*> switch (long "example"
|
||||
<> help "Include the Example Plugin. For Plugin devs only")
|
||||
|
||||
<*> switch
|
||||
( long "debug"
|
||||
<> short 'd'
|
||||
<> help "Generate debug output"
|
||||
)
|
||||
<*> optional (strOption
|
||||
( long "logfile"
|
||||
<> short 'l'
|
||||
<> metavar "LOGFILE"
|
||||
<> help "File to log to, defaults to stdout"
|
||||
))
|
||||
<*> option auto
|
||||
(short 'j'
|
||||
<> help "Number of threads (0: automatic)"
|
||||
<> metavar "NUM"
|
||||
<> value 0
|
||||
<> showDefault
|
||||
)
|
||||
<*> switch (long "project-ghc-version"
|
||||
<> help "Work out the project GHC version and print it")
|
||||
where
|
||||
lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP server")
|
||||
checkCommand = Check <$> many (argument str (metavar "FILES/DIRS..."))
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
haskellLanguageServerNumericVersion :: String
|
||||
haskellLanguageServerNumericVersion = showVersion version
|
||||
|
||||
haskellLanguageServerVersion :: IO String
|
||||
haskellLanguageServerVersion = do
|
||||
path <- getExecutablePath
|
||||
let gi = $$tGitInfoCwdTry
|
||||
gitHashSection = case gi of
|
||||
Right gi -> " (GIT hash: " <> giHash gi <> ")"
|
||||
Left _ -> ""
|
||||
return $ "haskell-language-server version: " <> haskellLanguageServerNumericVersion
|
||||
<> " (GHC: " <> VERSION_ghc
|
||||
<> ") (PATH: " <> path <> ")"
|
||||
<> gitHashSection
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
|
||||
|
||||
module Ide.Arguments
|
||||
( Arguments(..)
|
||||
, GhcideArguments(..)
|
||||
, PrintVersion(..)
|
||||
, BiosAction(..)
|
||||
, getArguments
|
||||
, haskellLanguageServerVersion
|
||||
, haskellLanguageServerNumericVersion
|
||||
) where
|
||||
|
||||
import Data.Version
|
||||
import Development.IDE (IdeState)
|
||||
import Development.IDE.Main (Command (..), commandP)
|
||||
import GitHash (giHash, tGitInfoCwdTry)
|
||||
import Ide.Types (IdePlugins)
|
||||
import Options.Applicative
|
||||
import Paths_haskell_language_server
|
||||
import System.Environment
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
data Arguments
|
||||
= VersionMode PrintVersion
|
||||
| ProbeToolsMode
|
||||
| ListPluginsMode
|
||||
| BiosMode BiosAction
|
||||
| Ghcide GhcideArguments
|
||||
| VSCodeExtensionSchemaMode
|
||||
| DefaultConfigurationMode
|
||||
|
||||
data GhcideArguments = GhcideArguments
|
||||
{argsCommand :: Command
|
||||
,argsCwd :: Maybe FilePath
|
||||
,argsShakeProfiling :: Maybe FilePath
|
||||
,argsTesting :: Bool
|
||||
,argsExamplePlugin :: Bool
|
||||
-- These next two are for compatibility with existing hie clients, allowing
|
||||
-- them to just change the name of the exe and still work.
|
||||
, argsDebugOn :: Bool
|
||||
, argsLogFile :: Maybe String
|
||||
, argsThreads :: Int
|
||||
, argsProjectGhcVersion :: Bool
|
||||
} deriving Show
|
||||
|
||||
data PrintVersion
|
||||
= PrintVersion
|
||||
| PrintNumericVersion
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data BiosAction
|
||||
= PrintCradleType
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
getArguments :: String -> IdePlugins IdeState -> IO Arguments
|
||||
getArguments exeName plugins = execParser opts
|
||||
where
|
||||
opts = info ((
|
||||
VersionMode <$> printVersionParser exeName
|
||||
<|> probeToolsParser exeName
|
||||
<|> listPluginsParser
|
||||
<|> BiosMode <$> biosParser
|
||||
<|> Ghcide <$> arguments plugins
|
||||
)
|
||||
<**> helper)
|
||||
( fullDesc
|
||||
<> progDesc "Used as a test bed to check your IDE Client will work"
|
||||
<> header (exeName ++ " - GHC Haskell LSP server"))
|
||||
|
||||
printVersionParser :: String -> Parser PrintVersion
|
||||
printVersionParser exeName =
|
||||
flag' PrintVersion
|
||||
(long "version" <> help ("Show " ++ exeName ++ " and GHC versions"))
|
||||
<|>
|
||||
flag' PrintNumericVersion
|
||||
(long "numeric-version" <> help ("Show numeric version of " ++ exeName))
|
||||
|
||||
biosParser :: Parser BiosAction
|
||||
biosParser =
|
||||
flag' PrintCradleType
|
||||
(long "print-cradle" <> help "Print the project cradle type")
|
||||
|
||||
probeToolsParser :: String -> Parser Arguments
|
||||
probeToolsParser exeName =
|
||||
flag' ProbeToolsMode
|
||||
(long "probe-tools" <> help ("Show " ++ exeName ++ " version and other tools of interest"))
|
||||
|
||||
listPluginsParser :: Parser Arguments
|
||||
listPluginsParser =
|
||||
flag' ListPluginsMode
|
||||
(long "list-plugins" <> help "List all available plugins")
|
||||
|
||||
arguments :: IdePlugins IdeState -> Parser GhcideArguments
|
||||
arguments plugins = GhcideArguments
|
||||
<$> (commandP plugins <|> lspCommand <|> checkCommand)
|
||||
<*> optional (strOption $ long "cwd" <> metavar "DIR"
|
||||
<> help "Change to this directory")
|
||||
<*> optional (strOption $ long "shake-profiling" <> metavar "DIR"
|
||||
<> help "Dump profiling reports to this directory")
|
||||
<*> switch (long "test"
|
||||
<> help "Enable additional lsp messages used by the testsuite")
|
||||
<*> switch (long "example"
|
||||
<> help "Include the Example Plugin. For Plugin devs only")
|
||||
|
||||
<*> switch
|
||||
( long "debug"
|
||||
<> short 'd'
|
||||
<> help "Generate debug output"
|
||||
)
|
||||
<*> optional (strOption
|
||||
( long "logfile"
|
||||
<> short 'l'
|
||||
<> metavar "LOGFILE"
|
||||
<> help "File to log to, defaults to stdout"
|
||||
))
|
||||
<*> option auto
|
||||
(short 'j'
|
||||
<> help "Number of threads (0: automatic)"
|
||||
<> metavar "NUM"
|
||||
<> value 0
|
||||
<> showDefault
|
||||
)
|
||||
<*> switch (long "project-ghc-version"
|
||||
<> help "Work out the project GHC version and print it")
|
||||
where
|
||||
lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP server")
|
||||
checkCommand = Check <$> many (argument str (metavar "FILES/DIRS..."))
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
haskellLanguageServerNumericVersion :: String
|
||||
haskellLanguageServerNumericVersion = showVersion version
|
||||
|
||||
haskellLanguageServerVersion :: IO String
|
||||
haskellLanguageServerVersion = do
|
||||
path <- getExecutablePath
|
||||
let gi = $$tGitInfoCwdTry
|
||||
gitHashSection = case gi of
|
||||
Right gi -> " (GIT hash: " <> giHash gi <> ")"
|
||||
Left _ -> ""
|
||||
return $ "haskell-language-server version: " <> haskellLanguageServerNumericVersion
|
||||
<> " (GHC: " <> VERSION_ghc
|
||||
<> ") (PATH: " <> path <> ")"
|
||||
<> gitHashSection
|
||||
|
||||
@ -1,82 +1,82 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
-- | Information and display strings for HIE's version
|
||||
-- and the current project's version
|
||||
module Ide.Version where
|
||||
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Data.Version
|
||||
import GitHash (giCommitCount, tGitInfoCwdTry)
|
||||
import Options.Applicative.Simple (simpleVersion)
|
||||
import qualified Paths_haskell_language_server as Meta
|
||||
import System.Directory
|
||||
import System.Exit
|
||||
import System.Info
|
||||
import System.Process
|
||||
import Text.ParserCombinators.ReadP
|
||||
|
||||
-- >>> hlsVersion
|
||||
hlsVersion :: String
|
||||
hlsVersion =
|
||||
let gi = $$tGitInfoCwdTry
|
||||
commitCount = case gi of
|
||||
Right gi -> show $ giCommitCount gi
|
||||
Left _ -> "UNKNOWN"
|
||||
in concat $ concat
|
||||
[ [$(simpleVersion Meta.version)]
|
||||
-- Leave out number of commits for --depth=1 clone
|
||||
-- See https://github.com/commercialhaskell/stack/issues/792
|
||||
, [" (" ++ commitCount ++ " commits)" | commitCount /= ("1"::String) &&
|
||||
commitCount /= ("UNKNOWN" :: String)]
|
||||
, [" ", arch]
|
||||
, [" ", hlsGhcDisplayVersion]
|
||||
]
|
||||
where
|
||||
hlsGhcDisplayVersion = compilerName ++ "-" ++ VERSION_ghc
|
||||
|
||||
data ProgramsOfInterest = ProgramsOfInterest
|
||||
{ cabalVersion :: Maybe Version
|
||||
, stackVersion :: Maybe Version
|
||||
, ghcVersion :: Maybe Version
|
||||
}
|
||||
|
||||
showProgramVersionOfInterest :: ProgramsOfInterest -> String
|
||||
showProgramVersionOfInterest ProgramsOfInterest {..} =
|
||||
unlines
|
||||
[ "cabal:\t\t" ++ showVersionWithDefault cabalVersion
|
||||
, "stack:\t\t" ++ showVersionWithDefault stackVersion
|
||||
, "ghc:\t\t" ++ showVersionWithDefault ghcVersion
|
||||
]
|
||||
where
|
||||
showVersionWithDefault :: Maybe Version -> String
|
||||
showVersionWithDefault = maybe "Not found" showVersion
|
||||
|
||||
findProgramVersions :: IO ProgramsOfInterest
|
||||
findProgramVersions = ProgramsOfInterest
|
||||
<$> findVersionOf "cabal"
|
||||
<*> findVersionOf "stack"
|
||||
<*> findVersionOf "ghc"
|
||||
|
||||
-- | Find the version of the given program.
|
||||
-- Assumes the program accepts the cli argument "--numeric-version".
|
||||
-- If the invocation has a non-zero exit-code, we return 'Nothing'
|
||||
findVersionOf :: FilePath -> IO (Maybe Version)
|
||||
findVersionOf tool =
|
||||
findExecutable tool >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just path ->
|
||||
readProcessWithExitCode path ["--numeric-version"] "" >>= \case
|
||||
(ExitSuccess, sout, _) -> pure $ consumeParser myVersionParser sout
|
||||
_ -> pure Nothing
|
||||
where
|
||||
myVersionParser = do
|
||||
skipSpaces
|
||||
version <- parseVersion
|
||||
skipSpaces
|
||||
pure version
|
||||
|
||||
consumeParser :: ReadP a -> String -> Maybe a
|
||||
consumeParser p input = listToMaybe $ map fst . filter (null . snd) $ readP_to_S p input
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
-- | Information and display strings for HIE's version
|
||||
-- and the current project's version
|
||||
module Ide.Version where
|
||||
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Data.Version
|
||||
import GitHash (giCommitCount, tGitInfoCwdTry)
|
||||
import Options.Applicative.Simple (simpleVersion)
|
||||
import qualified Paths_haskell_language_server as Meta
|
||||
import System.Directory
|
||||
import System.Exit
|
||||
import System.Info
|
||||
import System.Process
|
||||
import Text.ParserCombinators.ReadP
|
||||
|
||||
-- >>> hlsVersion
|
||||
hlsVersion :: String
|
||||
hlsVersion =
|
||||
let gi = $$tGitInfoCwdTry
|
||||
commitCount = case gi of
|
||||
Right gi -> show $ giCommitCount gi
|
||||
Left _ -> "UNKNOWN"
|
||||
in concat $ concat
|
||||
[ [$(simpleVersion Meta.version)]
|
||||
-- Leave out number of commits for --depth=1 clone
|
||||
-- See https://github.com/commercialhaskell/stack/issues/792
|
||||
, [" (" ++ commitCount ++ " commits)" | commitCount /= ("1"::String) &&
|
||||
commitCount /= ("UNKNOWN" :: String)]
|
||||
, [" ", arch]
|
||||
, [" ", hlsGhcDisplayVersion]
|
||||
]
|
||||
where
|
||||
hlsGhcDisplayVersion = compilerName ++ "-" ++ VERSION_ghc
|
||||
|
||||
data ProgramsOfInterest = ProgramsOfInterest
|
||||
{ cabalVersion :: Maybe Version
|
||||
, stackVersion :: Maybe Version
|
||||
, ghcVersion :: Maybe Version
|
||||
}
|
||||
|
||||
showProgramVersionOfInterest :: ProgramsOfInterest -> String
|
||||
showProgramVersionOfInterest ProgramsOfInterest {..} =
|
||||
unlines
|
||||
[ "cabal:\t\t" ++ showVersionWithDefault cabalVersion
|
||||
, "stack:\t\t" ++ showVersionWithDefault stackVersion
|
||||
, "ghc:\t\t" ++ showVersionWithDefault ghcVersion
|
||||
]
|
||||
where
|
||||
showVersionWithDefault :: Maybe Version -> String
|
||||
showVersionWithDefault = maybe "Not found" showVersion
|
||||
|
||||
findProgramVersions :: IO ProgramsOfInterest
|
||||
findProgramVersions = ProgramsOfInterest
|
||||
<$> findVersionOf "cabal"
|
||||
<*> findVersionOf "stack"
|
||||
<*> findVersionOf "ghc"
|
||||
|
||||
-- | Find the version of the given program.
|
||||
-- Assumes the program accepts the cli argument "--numeric-version".
|
||||
-- If the invocation has a non-zero exit-code, we return 'Nothing'
|
||||
findVersionOf :: FilePath -> IO (Maybe Version)
|
||||
findVersionOf tool =
|
||||
findExecutable tool >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just path ->
|
||||
readProcessWithExitCode path ["--numeric-version"] "" >>= \case
|
||||
(ExitSuccess, sout, _) -> pure $ consumeParser myVersionParser sout
|
||||
_ -> pure Nothing
|
||||
where
|
||||
myVersionParser = do
|
||||
skipSpaces
|
||||
version <- parseVersion
|
||||
skipSpaces
|
||||
pure version
|
||||
|
||||
consumeParser :: ReadP a -> String -> Maybe a
|
||||
consumeParser p input = listToMaybe $ map fst . filter (null . snd) $ readP_to_S p input
|
||||
|
||||
Loading…
Reference in New Issue
Block a user