From 411db02883d6985efb37918a0b9100d727fe8554 Mon Sep 17 00:00:00 2001 From: Nick Suchecki <40047416+drsooch@users.noreply.github.com> Date: Fri, 4 Feb 2022 09:50:18 -0500 Subject: [PATCH] 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 7b9670f86320156a79e570ef29b331ac36172bfe. * 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 Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com> --- .gitignore | 2 +- .pre-commit-config.yaml | 32 + .stylish-haskell.yaml | 2 +- docs/contributing/contributing.md | 11 + ghcide/src/Development/IDE/Core/UseStale.hs | 324 ++-- ghcide/src/Development/IDE/GHC/CPP.hs | 126 +- ghcide/src/Development/IDE/GHC/Compat/CPP.hs | 408 ++--- ghcide/src/Development/IDE/Main/HeapStats.hs | 106 +- .../IDE/Plugin/Completions/Logic.hs | 2 +- .../Development/IDE/Spans/Documentation.hs | 448 +++--- .../Development/IDE/Spans/LocalBindings.hs | 280 ++-- ghcide/src/Development/IDE/Types/HscEnvEq.hs | 306 ++-- ghcide/src/Generics/SYB/GHC.hs | 248 +-- hls-graph/html/ts/jquery.flot.d.ts | 478 +++--- .../src/Development/IDE/Graph/Classes.hs | 16 +- .../Development/IDE/Graph/Internal/Action.hs | 274 ++-- .../Development/IDE/Graph/Internal/Rules.hs | 116 +- hls-graph/src/Paths.hs | 24 +- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 1144 +++++++------- .../test/info-util/InfoUtil.hs | 40 +- .../src/Ide/Plugin/Retrie.hs | 2 +- .../src/Ide/Plugin/StylishHaskell.hs | 158 +- .../src/Development/Benchmark/Rules.hs | 1408 ++++++++--------- src/Ide/Arguments.hs | 302 ++-- src/Ide/Version.hs | 164 +- 25 files changed, 3232 insertions(+), 3189 deletions(-) create mode 100644 .pre-commit-config.yaml diff --git a/.gitignore b/.gitignore index bb95f7c0a..97cc35247 100644 --- a/.gitignore +++ b/.gitignore @@ -32,7 +32,7 @@ test/testdata/**/hie.yaml .shake/ # pre-commit-hook.nix -.pre-commit-config.yaml +#.pre-commit-config.yaml # direnv /.direnv/ diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml new file mode 100644 index 000000000..b2bac28fc --- /dev/null +++ b/.pre-commit-config.yaml @@ -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$" + } + ] + } + ] +} diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml index 5896976a7..f64e341e9 100644 --- a/.stylish-haskell.yaml +++ b/.stylish-haskell.yaml @@ -53,7 +53,7 @@ steps: columns: 80 -newline: native +newline: lf language_extensions: - BangPatterns diff --git a/docs/contributing/contributing.md b/docs/contributing/contributing.md index afb73a413..6a9de2529 100644 --- a/docs/contributing/contributing.md +++ b/docs/contributing/contributing.md @@ -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$" + } + ] } ] } diff --git a/ghcide/src/Development/IDE/Core/UseStale.hs b/ghcide/src/Development/IDE/Core/UseStale.hs index d95e8e367..ab6a0afa4 100644 --- a/ghcide/src/Development/IDE/Core/UseStale.hs +++ b/ghcide/src/Development/IDE/Core/UseStale.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) + diff --git a/ghcide/src/Development/IDE/GHC/CPP.hs b/ghcide/src/Development/IDE/GHC/CPP.hs index b50dad920..788e93ea8 100644 --- a/ghcide/src/Development/IDE/GHC/CPP.hs +++ b/ghcide/src/Development/IDE/GHC/CPP.hs @@ -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 + diff --git a/ghcide/src/Development/IDE/GHC/Compat/CPP.hs b/ghcide/src/Development/IDE/GHC/Compat/CPP.hs index 44f4ba51d..b9063e8a9 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/CPP.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/CPP.hs @@ -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 diff --git a/ghcide/src/Development/IDE/Main/HeapStats.hs b/ghcide/src/Development/IDE/Main/HeapStats.hs index db4bdd09e..de17eef1d 100644 --- a/ghcide/src/Development/IDE/Main/HeapStats.hs +++ b/ghcide/src/Development/IDE/Main/HeapStats.hs @@ -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 diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index f1017eea9..b7a538aba 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -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 diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index cb540eac9..ffa2a25c6 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -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 diff --git a/ghcide/src/Development/IDE/Spans/LocalBindings.hs b/ghcide/src/Development/IDE/Spans/LocalBindings.hs index 8c3871419..0fd74cf0d 100644 --- a/ghcide/src/Development/IDE/Spans/LocalBindings.hs +++ b/ghcide/src/Development/IDE/Spans/LocalBindings.hs @@ -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 _ = "" - - ------------------------------------------------------------------------------- --- | 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 _ = "" + + +------------------------------------------------------------------------------ +-- | 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 + diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index c7eefda96..efb89b971 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -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) diff --git a/ghcide/src/Generics/SYB/GHC.hs b/ghcide/src/Generics/SYB/GHC.hs index 7a4d1a663..8aaf99fa3 100644 --- a/ghcide/src/Generics/SYB/GHC.hs +++ b/ghcide/src/Generics/SYB/GHC.hs @@ -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) diff --git a/hls-graph/html/ts/jquery.flot.d.ts b/hls-graph/html/ts/jquery.flot.d.ts index a2d8d238d..8535c915f 100644 --- a/hls-graph/html/ts/jquery.flot.d.ts +++ b/hls-graph/html/ts/jquery.flot.d.ts @@ -1,240 +1,240 @@ -// Type definitions for Flot -// Project: http://www.flotcharts.org/ -// Definitions by: Matt Burland -// 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 +// 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; +} diff --git a/hls-graph/src/Development/IDE/Graph/Classes.hs b/hls-graph/src/Development/IDE/Graph/Classes.hs index a060c7aae..ff9a37c5e 100644 --- a/hls-graph/src/Development/IDE/Graph/Classes.hs +++ b/hls-graph/src/Development/IDE/Graph/Classes.hs @@ -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 diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 14985d85f..2f6b1e38c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -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 diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs index 5b0405259..a22f0c61e 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs @@ -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 diff --git a/hls-graph/src/Paths.hs b/hls-graph/src/Paths.hs index e4b31f653..291acafad 100644 --- a/hls-graph/src/Paths.hs +++ b/hls-graph/src/Paths.hs @@ -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] diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index 11d60355a..c937d631f 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -1,572 +1,572 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} - -module Ide.Plugin.Eval.Parse.Comments where - -import qualified Control.Applicative.Combinators.NonEmpty as NE -import Control.Arrow (first, (&&&), (>>>)) -import Control.Lens (lensField, lensRules, - view, (.~), (^.)) -import Control.Lens.Extras (is) -import Control.Lens.TH (makeLensesWith, - makePrisms, - mappingNamer) -import Control.Monad (guard, void, when) -import Control.Monad.Combinators () -import Control.Monad.Reader (ask) -import Control.Monad.Trans.Reader (Reader, runReader) -import qualified Data.Char as C -import qualified Data.DList as DL -import qualified Data.Foldable as F -import Data.Function ((&)) -import Data.Functor ((<&>)) -import Data.Functor.Identity -import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import qualified Data.Text as T -import Data.Void (Void) -import Development.IDE (Position, - Range (Range)) -import Development.IDE.Types.Location (Position (..)) -import GHC.Generics hiding (UInt, to) -import Ide.Plugin.Eval.Types -import Language.LSP.Types (UInt) -import Language.LSP.Types.Lens (character, end, line, - start) -import Text.Megaparsec -import qualified Text.Megaparsec as P -import Text.Megaparsec.Char (alphaNumChar, char, - eol, hspace, - letterChar) - -{- -We build parsers combining the following three kinds of them: - - * Line parser - paring a single line into an input, - works both for line- and block-comments. - A line should be a proper content of lines contained in comment: - doesn't include starting @--@ and @{\-@ and no ending @-\}@ - - * Line comment group parser: parses a contiguous group of - tuples of position and line comment into sections of line comments. - Each input MUST start with @--@. - - * Block comment parser: Parsing entire block comment into sections. - Input must be surrounded by @{\-@ and @-\}@. --} - --- | Line parser -type LineParser a = forall m. Monad m => ParsecT Void String m a - --- | Line comment group parser -type LineGroupParser = Parsec Void [(Range, RawLineComment)] - -data BlockEnv = BlockEnv - { isLhs :: Bool - , blockRange :: Range - } - deriving (Read, Show, Eq, Ord) - -makeLensesWith - (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) - ''BlockEnv - --- | Block comment parser -type BlockCommentParser = ParsecT Void String (Reader BlockEnv) - --- | Prop line, with "prop>" stripped off -newtype PropLine = PropLine {getPropLine :: String} - deriving (Show) - --- | Example line, with @>>>@ stripped off -newtype ExampleLine = ExampleLine {getExampleLine :: String} - deriving (Show) - -data TestComment - = AProp - { testCommentRange :: Range - , lineProp :: PropLine - , propResults :: [String] - } - | AnExample - { testCommentRange :: Range - , lineExamples :: NonEmpty ExampleLine - , exampleResults :: [String] - } - deriving (Show) - --- | Classification of comments -data CommentFlavour = Vanilla | HaddockNext | HaddockPrev | Named String - deriving (Read, Show, Eq, Ord) - --- | Single line or block comments? -data CommentStyle = Line | Block Range - deriving (Read, Show, Eq, Ord, Generic) - -makePrisms ''CommentStyle - -commentsToSections :: - -- | True if it is literate Haskell - Bool -> - Comments -> - Sections -commentsToSections isLHS Comments {..} = - let (lineSectionSeeds, lineSetupSeeds) = - foldMap - ( \lcs -> - let theRan = - Range - (view start $ fst $ NE.head lcs) - (view end $ fst $ NE.last lcs) - in case parseMaybe lineGroupP $ NE.toList lcs of - Nothing -> mempty - Just (mls, rs) -> - ( maybe mempty (uncurry Map.singleton) ((theRan,) <$> mls) - , -- orders setup sections in ascending order - if null rs - then mempty - else - Map.singleton theRan $ - DL.singleton (Line, rs) - ) - ) - $ groupLineComments $ - Map.filterWithKey - -- FIXME: - -- To comply with the initial behaviour of - -- Extended Eval Plugin; - -- but it also rejects modules with - -- non-zero base indentation level! - ( \pos _ -> - if isLHS - then pos ^. start . character == 2 - else pos ^. start . character == 0 - ) - lineComments - (blockSeed, blockSetupSeeds) = - foldMap - ( \(ran, lcs) -> - case parseBlockMaybe isLHS ran blockCommentBP $ - getRawBlockComment lcs of - Nothing -> mempty - Just (Named "setup", grp) -> - -- orders setup sections in ascending order - ( mempty - , Map.singleton ran $ - DL.singleton (Block ran, grp) - ) - Just grp -> - ( Map.singleton ran grp - , mempty - ) - ) - -- It seems Extended Eval Plugin doesn't constraint - -- starting indentation level for block comments. - -- Rather, it constrains the indentation level /inside/ - -- block comment body. - $ Map.toList blockComments - lineSections = - lineSectionSeeds <&> uncurry (testsToSection Line) - multilineSections = - Map.mapWithKey - (uncurry . testsToSection . Block) - blockSeed - setupSections = - -- Setups doesn't need Dummy position - map - ( \(style, tests) -> - testsToSection - style - (Named "setup") - tests - ) - $ DL.toList $ - F.fold $ - Map.unionWith (<>) lineSetupSeeds blockSetupSeeds - nonSetupSections = F.toList $ lineSections `Map.union` multilineSections - in Sections {..} - -parseBlockMaybe :: Bool -> Range -> BlockCommentParser a -> String -> Maybe a -parseBlockMaybe isLhs blockRange p i = - case runReader (runParserT p' "" i) BlockEnv {..} of - Left {} -> Nothing - Right a -> Just a - where - p' = do - updateParserState $ \st -> - st - { statePosState = - (statePosState st) - { pstateSourcePos = positionToSourcePos $ blockRange ^. start - } - } - p - -type CommentRange = Range - -type SectionRange = Range - -testsToSection :: - CommentStyle -> - CommentFlavour -> - [TestComment] -> - Section -testsToSection style flav tests = - let sectionName - | Named name <- flav = name - | otherwise = "" - sectionLanguage = case flav of - HaddockNext -> Haddock - HaddockPrev -> Haddock - _ -> Plain - sectionTests = map fromTestComment tests - sectionFormat = - case style of - Line -> SingleLine - Block ran -> MultiLine ran - in Section {..} - -fromTestComment :: TestComment -> Test -fromTestComment AProp {..} = - Property - { testline = getPropLine lineProp - , testOutput = propResults - , testRange = testCommentRange - } -fromTestComment AnExample {..} = - Example - { testLines = getExampleLine <$> lineExamples - , testOutput = exampleResults - , testRange = testCommentRange - } - --- * Block comment parser - -{- $setup ->>> dummyPos = Position 0 0 ->>> parseE p = either (error . errorBundlePretty) id . parse p "" --} - --- >>> parseE (blockCommentBP True dummyPos) "{- |\n >>> 5+5\n 11\n -}" --- (HaddockNext,[AnExample {testCommentRange = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " 5+5"} :| [], exampleResults = [" 11"]}]) - -blockCommentBP :: - -- | True if Literate Haskell - BlockCommentParser (CommentFlavour, [TestComment]) -blockCommentBP = do - skipCount 2 anySingle -- "{-" - void $ optional $ char ' ' - flav <- commentFlavourP - hit <- skipNormalCommentBlock - if hit - then do - body <- - many $ - (blockExamples <|> blockProp) - <* skipNormalCommentBlock - void takeRest -- just consume the rest - pure (flav, body) - else pure (flav, []) - -skipNormalCommentBlock :: BlockCommentParser Bool -skipNormalCommentBlock = do - BlockEnv {..} <- ask - skipManyTill (normalLineP isLhs $ Block blockRange) $ - False <$ try (optional (chunk "-}") *> eof) - <|> True <$ lookAhead (try $ testSymbol isLhs $ Block blockRange) - -testSymbol :: Bool -> CommentStyle -> LineParser () -testSymbol isLHS style = - -- FIXME: To comply with existing Extended Eval Plugin Behaviour; - -- it must skip one space after a comment! - -- This prevents Eval Plugin from working on - -- modules with non-standard base indentation-level. - when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') - *> (exampleSymbol <|> propSymbol) - -eob :: LineParser () -eob = eof <|> try (optional (chunk "-}") *> eof) <|> void eol - -blockExamples - , blockProp :: - BlockCommentParser TestComment -blockExamples = do - BlockEnv {..} <- ask - (ran, examples) <- withRange $ NE.some $ exampleLineStrP isLhs $ Block blockRange - AnExample ran examples <$> resultBlockP -blockProp = do - BlockEnv {..} <- ask - (ran, Identity prop) <- withRange $ fmap Identity $ propLineStrP isLhs $ Block blockRange - AProp ran prop <$> resultBlockP - -withRange :: - (TraversableStream s, Stream s, Monad m, Ord v, Traversable t) => - ParsecT v s m (t (a, Position)) -> - ParsecT v s m (Range, t a) -withRange p = do - beg <- sourcePosToPosition <$> getSourcePos - as <- p - let fin - | null as = beg - | otherwise = snd $ last $ F.toList as - pure (Range beg fin, fst <$> as) - -resultBlockP :: BlockCommentParser [String] -resultBlockP = do - BlockEnv {..} <- ask - many $ - fmap fst $ nonEmptyNormalLineP isLhs $ - Block blockRange - -positionToSourcePos :: Position -> SourcePos -positionToSourcePos pos = - P.SourcePos - { sourceName = "" - , sourceLine = P.mkPos $ fromIntegral $ 1 + pos ^. line - , sourceColumn = P.mkPos $ fromIntegral $ 1 + pos ^. character - } - -sourcePosToPosition :: SourcePos -> Position -sourcePosToPosition SourcePos {..} = - Position (fromIntegral $ unPos sourceLine - 1) (fromIntegral $ unPos sourceColumn - 1) - --- * Line Group Parser - -{- | -Result: a tuple of ordinary line tests and setting sections. - -TODO: Haddock comment can adjacent to vanilla comment: - - @ - -- Vanilla comment - -- Another vanilla - -- | This parses as Haddock comment as GHC - @ - -This behaviour is not yet handled correctly in Eval Plugin; -but for future extension for this, we use a tuple here instead of 'Either'. --} -lineGroupP :: - LineGroupParser - (Maybe (CommentFlavour, [TestComment]), [TestComment]) -lineGroupP = do - (_, flav) <- lookAhead $ parseLine (commentFlavourP <* takeRest) - case flav of - Named "setup" -> (Nothing,) <$> lineCommentSectionsP - flav -> (,mempty) . Just . (flav,) <$> lineCommentSectionsP - --- >>> parse (lineGroupP <*eof) "" $ (dummyPosition, ) . RawLineComment <$> ["-- a", "-- b"] --- Variable not in scope: dummyPosition :: Position - -commentFlavourP :: LineParser CommentFlavour -commentFlavourP = - P.option - Vanilla - ( HaddockNext <$ char '|' - <|> HaddockPrev <$ char '^' - <|> Named <$ char '$' - <* optional hspace - <*> ((:) <$> letterChar <*> P.many alphaNumChar) - ) - <* optional (char ' ') - -lineCommentHeadP :: LineParser () -lineCommentHeadP = do - -- and no operator symbol character follows. - void $ chunk "--" - skipMany $ char '-' - void $ optional $ char ' ' - -lineCommentSectionsP :: - LineGroupParser [TestComment] -lineCommentSectionsP = do - skipMany normalLineCommentP - many $ - exampleLinesGP - <|> uncurry AProp <$> propLineGP <*> resultLinesP - <* skipMany normalLineCommentP - -lexemeLine :: LineGroupParser a -> LineGroupParser a -lexemeLine p = p <* skipMany normalLineCommentP - -resultLinesP :: LineGroupParser [String] -resultLinesP = many nonEmptyLGP - -normalLineCommentP :: LineGroupParser (Range, String) -normalLineCommentP = - parseLine (fst <$ commentFlavourP <*> normalLineP False Line) - -nonEmptyLGP :: LineGroupParser String -nonEmptyLGP = - try $ - fmap snd $ - parseLine $ - fst <$ commentFlavourP <*> nonEmptyNormalLineP False Line - -exampleLinesGP :: LineGroupParser TestComment -exampleLinesGP = - lexemeLine $ - uncurry AnExample . first convexHullRange . NE.unzip - <$> NE.some exampleLineGP - <*> resultLinesP - -convexHullRange :: NonEmpty Range -> Range -convexHullRange nes = - Range (NE.head nes ^. start) (NE.last nes ^. end) - -exampleLineGP :: LineGroupParser (Range, ExampleLine) -exampleLineGP = - -- In line-comments, indentation-level inside comment doesn't matter. - parseLine (fst <$ commentFlavourP <*> exampleLineStrP False Line) - -propLineGP :: LineGroupParser (Range, PropLine) -propLineGP = - -- In line-comments, indentation-level inside comment doesn't matter. - parseLine (fst <$ commentFlavourP <*> propLineStrP False Line) - -{- | -Turning a line parser into line group parser consuming a single line comment. -Parses a sinlge line comment, skipping prefix "--[-*]" with optional one horizontal space. -fails if the input does not start with "--". - -__N.B.__ We don't strip comment flavours. - ->>> pck = (:[]).(:[]) . RawLineComment - ->>> parseMaybe (parseLine $ takeRest) $ pck "-- >>> A" -Just [">>> A"] - ->>> parseMaybe (parseLine $ takeRest) $ pck "--- >>> A" -Just [" >>> A"] - ->>> parseMaybe (parseLine takeRest) $ pck "" -Nothing --} -parseLine :: - (Ord (f RawLineComment), Traversable f) => - LineParser a -> - Parsec Void [f RawLineComment] (f a) -parseLine p = - P.token - (mapM $ parseMaybe (lineCommentHeadP *> p) . getRawLineComment) - mempty - --- * Line Parsers - --- | Non-empty normal line. -nonEmptyNormalLineP :: - -- | True if Literate Haskell - Bool -> - CommentStyle -> - LineParser (String, Position) -nonEmptyNormalLineP isLHS style = try $ do - (ln, pos) <- normalLineP isLHS style - guard $ - case style of - Block{} -> T.strip (T.pack ln) `notElem` ["{-", "-}", ""] - _ -> not $ all C.isSpace ln - pure (ln, pos) - -{- | Normal line is a line neither a example nor prop. - Empty line is normal. --} -normalLineP :: - -- | True if Literate Haskell - Bool -> - CommentStyle -> - LineParser (String, Position) -normalLineP isLHS style = do - notFollowedBy - (try $ testSymbol isLHS style) - when (isLHS && is _Block style) $ - void $ count' 0 2 $ char ' ' - consume style - -consume :: CommentStyle -> LineParser (String, Position) -consume style = - case style of - Line -> (,) <$> takeRest <*> getPosition - Block {} -> manyTill_ anySingle (getPosition <* eob) - -getPosition :: (Ord v, TraversableStream s) => ParsecT v s m Position -getPosition = sourcePosToPosition <$> getSourcePos - --- | Parses example test line. -exampleLineStrP :: - -- | True if Literate Haskell - Bool -> - CommentStyle -> - LineParser (ExampleLine, Position) -exampleLineStrP isLHS style = - try $ - -- FIXME: To comply with existing Extended Eval Plugin Behaviour; - -- it must skip one space after a comment! - -- This prevents Eval Plugin from working on - -- modules with non-standard base indentation-level. - when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') - *> exampleSymbol - *> (first ExampleLine <$> consume style) - -exampleSymbol :: LineParser () -exampleSymbol = - chunk ">>>" *> P.notFollowedBy (char '>') - -propSymbol :: LineParser () -propSymbol = chunk "prop>" *> P.notFollowedBy (char '>') - --- | Parses prop test line. -propLineStrP :: - -- | True if Literate HAskell - Bool -> - CommentStyle -> - LineParser (PropLine, Position) -propLineStrP isLHS style = - -- FIXME: To comply with existing Extended Eval Plugin Behaviour; - -- it must skip one space after a comment! - -- This prevents Eval Plugin from working on - -- modules with non-standard base indentation-level. - when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') - *> chunk "prop>" - *> P.notFollowedBy (char '>') - *> (first PropLine <$> consume style) - --- * Utilities - -{- | -Given a sequence of tokens increasing in their starting position, -groups them into sublists consisting of contiguous tokens; -Two adjacent tokens are considered to be contiguous if - - * line number increases by 1, and - * they have same starting column. - ->>> contiguousGroupOn id [(1,2),(2,2),(3,4),(4,4),(5,4),(7,0),(8,0)] -[(1,2) :| [(2,2)],(3,4) :| [(4,4),(5,4)],(7,0) :| [(8,0)]] --} -contiguousGroupOn :: (a -> (UInt, UInt)) -> [a] -> [NonEmpty a] -contiguousGroupOn toLineCol = foldr step [] - where - step a [] = [pure a] - step a bss0@((b :| bs) : bss) - | let (aLine, aCol) = toLineCol a - , let (bLine, bCol) = toLineCol b - , aLine + 1 == bLine && aCol == bCol = - (a :| b : bs) : bss - | otherwise = pure a : bss0 - -{- | Given a map from positions, divides them into subgroup - with contiguous line and columns. --} -groupLineComments :: - Map Range a -> [NonEmpty (Range, a)] -groupLineComments = - contiguousGroupOn (fst >>> view start >>> view line &&& view character) - . Map.toList +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Ide.Plugin.Eval.Parse.Comments where + +import qualified Control.Applicative.Combinators.NonEmpty as NE +import Control.Arrow (first, (&&&), (>>>)) +import Control.Lens (lensField, lensRules, + view, (.~), (^.)) +import Control.Lens.Extras (is) +import Control.Lens.TH (makeLensesWith, + makePrisms, + mappingNamer) +import Control.Monad (guard, void, when) +import Control.Monad.Combinators () +import Control.Monad.Reader (ask) +import Control.Monad.Trans.Reader (Reader, runReader) +import qualified Data.Char as C +import qualified Data.DList as DL +import qualified Data.Foldable as F +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.Functor.Identity +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Data.Void (Void) +import Development.IDE (Position, + Range (Range)) +import Development.IDE.Types.Location (Position (..)) +import GHC.Generics hiding (UInt, to) +import Ide.Plugin.Eval.Types +import Language.LSP.Types (UInt) +import Language.LSP.Types.Lens (character, end, line, + start) +import Text.Megaparsec +import qualified Text.Megaparsec as P +import Text.Megaparsec.Char (alphaNumChar, char, + eol, hspace, + letterChar) + +{- +We build parsers combining the following three kinds of them: + + * Line parser - paring a single line into an input, + works both for line- and block-comments. + A line should be a proper content of lines contained in comment: + doesn't include starting @--@ and @{\-@ and no ending @-\}@ + + * Line comment group parser: parses a contiguous group of + tuples of position and line comment into sections of line comments. + Each input MUST start with @--@. + + * Block comment parser: Parsing entire block comment into sections. + Input must be surrounded by @{\-@ and @-\}@. +-} + +-- | Line parser +type LineParser a = forall m. Monad m => ParsecT Void String m a + +-- | Line comment group parser +type LineGroupParser = Parsec Void [(Range, RawLineComment)] + +data BlockEnv = BlockEnv + { isLhs :: Bool + , blockRange :: Range + } + deriving (Read, Show, Eq, Ord) + +makeLensesWith + (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) + ''BlockEnv + +-- | Block comment parser +type BlockCommentParser = ParsecT Void String (Reader BlockEnv) + +-- | Prop line, with "prop>" stripped off +newtype PropLine = PropLine {getPropLine :: String} + deriving (Show) + +-- | Example line, with @>>>@ stripped off +newtype ExampleLine = ExampleLine {getExampleLine :: String} + deriving (Show) + +data TestComment + = AProp + { testCommentRange :: Range + , lineProp :: PropLine + , propResults :: [String] + } + | AnExample + { testCommentRange :: Range + , lineExamples :: NonEmpty ExampleLine + , exampleResults :: [String] + } + deriving (Show) + +-- | Classification of comments +data CommentFlavour = Vanilla | HaddockNext | HaddockPrev | Named String + deriving (Read, Show, Eq, Ord) + +-- | Single line or block comments? +data CommentStyle = Line | Block Range + deriving (Read, Show, Eq, Ord, Generic) + +makePrisms ''CommentStyle + +commentsToSections :: + -- | True if it is literate Haskell + Bool -> + Comments -> + Sections +commentsToSections isLHS Comments {..} = + let (lineSectionSeeds, lineSetupSeeds) = + foldMap + ( \lcs -> + let theRan = + Range + (view start $ fst $ NE.head lcs) + (view end $ fst $ NE.last lcs) + in case parseMaybe lineGroupP $ NE.toList lcs of + Nothing -> mempty + Just (mls, rs) -> + ( maybe mempty (uncurry Map.singleton) ((theRan,) <$> mls) + , -- orders setup sections in ascending order + if null rs + then mempty + else + Map.singleton theRan $ + DL.singleton (Line, rs) + ) + ) + $ groupLineComments $ + Map.filterWithKey + -- FIXME: + -- To comply with the initial behaviour of + -- Extended Eval Plugin; + -- but it also rejects modules with + -- non-zero base indentation level! + ( \pos _ -> + if isLHS + then pos ^. start . character == 2 + else pos ^. start . character == 0 + ) + lineComments + (blockSeed, blockSetupSeeds) = + foldMap + ( \(ran, lcs) -> + case parseBlockMaybe isLHS ran blockCommentBP $ + getRawBlockComment lcs of + Nothing -> mempty + Just (Named "setup", grp) -> + -- orders setup sections in ascending order + ( mempty + , Map.singleton ran $ + DL.singleton (Block ran, grp) + ) + Just grp -> + ( Map.singleton ran grp + , mempty + ) + ) + -- It seems Extended Eval Plugin doesn't constraint + -- starting indentation level for block comments. + -- Rather, it constrains the indentation level /inside/ + -- block comment body. + $ Map.toList blockComments + lineSections = + lineSectionSeeds <&> uncurry (testsToSection Line) + multilineSections = + Map.mapWithKey + (uncurry . testsToSection . Block) + blockSeed + setupSections = + -- Setups doesn't need Dummy position + map + ( \(style, tests) -> + testsToSection + style + (Named "setup") + tests + ) + $ DL.toList $ + F.fold $ + Map.unionWith (<>) lineSetupSeeds blockSetupSeeds + nonSetupSections = F.toList $ lineSections `Map.union` multilineSections + in Sections {..} + +parseBlockMaybe :: Bool -> Range -> BlockCommentParser a -> String -> Maybe a +parseBlockMaybe isLhs blockRange p i = + case runReader (runParserT p' "" i) BlockEnv {..} of + Left {} -> Nothing + Right a -> Just a + where + p' = do + updateParserState $ \st -> + st + { statePosState = + (statePosState st) + { pstateSourcePos = positionToSourcePos $ blockRange ^. start + } + } + p + +type CommentRange = Range + +type SectionRange = Range + +testsToSection :: + CommentStyle -> + CommentFlavour -> + [TestComment] -> + Section +testsToSection style flav tests = + let sectionName + | Named name <- flav = name + | otherwise = "" + sectionLanguage = case flav of + HaddockNext -> Haddock + HaddockPrev -> Haddock + _ -> Plain + sectionTests = map fromTestComment tests + sectionFormat = + case style of + Line -> SingleLine + Block ran -> MultiLine ran + in Section {..} + +fromTestComment :: TestComment -> Test +fromTestComment AProp {..} = + Property + { testline = getPropLine lineProp + , testOutput = propResults + , testRange = testCommentRange + } +fromTestComment AnExample {..} = + Example + { testLines = getExampleLine <$> lineExamples + , testOutput = exampleResults + , testRange = testCommentRange + } + +-- * Block comment parser + +{- $setup +>>> dummyPos = Position 0 0 +>>> parseE p = either (error . errorBundlePretty) id . parse p "" +-} + +-- >>> parseE (blockCommentBP True dummyPos) "{- |\n >>> 5+5\n 11\n -}" +-- (HaddockNext,[AnExample {testCommentRange = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " 5+5"} :| [], exampleResults = [" 11"]}]) + +blockCommentBP :: + -- | True if Literate Haskell + BlockCommentParser (CommentFlavour, [TestComment]) +blockCommentBP = do + skipCount 2 anySingle -- "{-" + void $ optional $ char ' ' + flav <- commentFlavourP + hit <- skipNormalCommentBlock + if hit + then do + body <- + many $ + (blockExamples <|> blockProp) + <* skipNormalCommentBlock + void takeRest -- just consume the rest + pure (flav, body) + else pure (flav, []) + +skipNormalCommentBlock :: BlockCommentParser Bool +skipNormalCommentBlock = do + BlockEnv {..} <- ask + skipManyTill (normalLineP isLhs $ Block blockRange) $ + False <$ try (optional (chunk "-}") *> eof) + <|> True <$ lookAhead (try $ testSymbol isLhs $ Block blockRange) + +testSymbol :: Bool -> CommentStyle -> LineParser () +testSymbol isLHS style = + -- FIXME: To comply with existing Extended Eval Plugin Behaviour; + -- it must skip one space after a comment! + -- This prevents Eval Plugin from working on + -- modules with non-standard base indentation-level. + when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') + *> (exampleSymbol <|> propSymbol) + +eob :: LineParser () +eob = eof <|> try (optional (chunk "-}") *> eof) <|> void eol + +blockExamples + , blockProp :: + BlockCommentParser TestComment +blockExamples = do + BlockEnv {..} <- ask + (ran, examples) <- withRange $ NE.some $ exampleLineStrP isLhs $ Block blockRange + AnExample ran examples <$> resultBlockP +blockProp = do + BlockEnv {..} <- ask + (ran, Identity prop) <- withRange $ fmap Identity $ propLineStrP isLhs $ Block blockRange + AProp ran prop <$> resultBlockP + +withRange :: + (TraversableStream s, Stream s, Monad m, Ord v, Traversable t) => + ParsecT v s m (t (a, Position)) -> + ParsecT v s m (Range, t a) +withRange p = do + beg <- sourcePosToPosition <$> getSourcePos + as <- p + let fin + | null as = beg + | otherwise = snd $ last $ F.toList as + pure (Range beg fin, fst <$> as) + +resultBlockP :: BlockCommentParser [String] +resultBlockP = do + BlockEnv {..} <- ask + many $ + fmap fst $ nonEmptyNormalLineP isLhs $ + Block blockRange + +positionToSourcePos :: Position -> SourcePos +positionToSourcePos pos = + P.SourcePos + { sourceName = "" + , sourceLine = P.mkPos $ fromIntegral $ 1 + pos ^. line + , sourceColumn = P.mkPos $ fromIntegral $ 1 + pos ^. character + } + +sourcePosToPosition :: SourcePos -> Position +sourcePosToPosition SourcePos {..} = + Position (fromIntegral $ unPos sourceLine - 1) (fromIntegral $ unPos sourceColumn - 1) + +-- * Line Group Parser + +{- | +Result: a tuple of ordinary line tests and setting sections. + +TODO: Haddock comment can adjacent to vanilla comment: + + @ + -- Vanilla comment + -- Another vanilla + -- | This parses as Haddock comment as GHC + @ + +This behaviour is not yet handled correctly in Eval Plugin; +but for future extension for this, we use a tuple here instead of 'Either'. +-} +lineGroupP :: + LineGroupParser + (Maybe (CommentFlavour, [TestComment]), [TestComment]) +lineGroupP = do + (_, flav) <- lookAhead $ parseLine (commentFlavourP <* takeRest) + case flav of + Named "setup" -> (Nothing,) <$> lineCommentSectionsP + flav -> (,mempty) . Just . (flav,) <$> lineCommentSectionsP + +-- >>> parse (lineGroupP <*eof) "" $ (dummyPosition, ) . RawLineComment <$> ["-- a", "-- b"] +-- Variable not in scope: dummyPosition :: Position + +commentFlavourP :: LineParser CommentFlavour +commentFlavourP = + P.option + Vanilla + ( HaddockNext <$ char '|' + <|> HaddockPrev <$ char '^' + <|> Named <$ char '$' + <* optional hspace + <*> ((:) <$> letterChar <*> P.many alphaNumChar) + ) + <* optional (char ' ') + +lineCommentHeadP :: LineParser () +lineCommentHeadP = do + -- and no operator symbol character follows. + void $ chunk "--" + skipMany $ char '-' + void $ optional $ char ' ' + +lineCommentSectionsP :: + LineGroupParser [TestComment] +lineCommentSectionsP = do + skipMany normalLineCommentP + many $ + exampleLinesGP + <|> uncurry AProp <$> propLineGP <*> resultLinesP + <* skipMany normalLineCommentP + +lexemeLine :: LineGroupParser a -> LineGroupParser a +lexemeLine p = p <* skipMany normalLineCommentP + +resultLinesP :: LineGroupParser [String] +resultLinesP = many nonEmptyLGP + +normalLineCommentP :: LineGroupParser (Range, String) +normalLineCommentP = + parseLine (fst <$ commentFlavourP <*> normalLineP False Line) + +nonEmptyLGP :: LineGroupParser String +nonEmptyLGP = + try $ + fmap snd $ + parseLine $ + fst <$ commentFlavourP <*> nonEmptyNormalLineP False Line + +exampleLinesGP :: LineGroupParser TestComment +exampleLinesGP = + lexemeLine $ + uncurry AnExample . first convexHullRange . NE.unzip + <$> NE.some exampleLineGP + <*> resultLinesP + +convexHullRange :: NonEmpty Range -> Range +convexHullRange nes = + Range (NE.head nes ^. start) (NE.last nes ^. end) + +exampleLineGP :: LineGroupParser (Range, ExampleLine) +exampleLineGP = + -- In line-comments, indentation-level inside comment doesn't matter. + parseLine (fst <$ commentFlavourP <*> exampleLineStrP False Line) + +propLineGP :: LineGroupParser (Range, PropLine) +propLineGP = + -- In line-comments, indentation-level inside comment doesn't matter. + parseLine (fst <$ commentFlavourP <*> propLineStrP False Line) + +{- | +Turning a line parser into line group parser consuming a single line comment. +Parses a sinlge line comment, skipping prefix "--[-*]" with optional one horizontal space. +fails if the input does not start with "--". + +__N.B.__ We don't strip comment flavours. + +>>> pck = (:[]).(:[]) . RawLineComment + +>>> parseMaybe (parseLine $ takeRest) $ pck "-- >>> A" +Just [">>> A"] + +>>> parseMaybe (parseLine $ takeRest) $ pck "--- >>> A" +Just [" >>> A"] + +>>> parseMaybe (parseLine takeRest) $ pck "" +Nothing +-} +parseLine :: + (Ord (f RawLineComment), Traversable f) => + LineParser a -> + Parsec Void [f RawLineComment] (f a) +parseLine p = + P.token + (mapM $ parseMaybe (lineCommentHeadP *> p) . getRawLineComment) + mempty + +-- * Line Parsers + +-- | Non-empty normal line. +nonEmptyNormalLineP :: + -- | True if Literate Haskell + Bool -> + CommentStyle -> + LineParser (String, Position) +nonEmptyNormalLineP isLHS style = try $ do + (ln, pos) <- normalLineP isLHS style + guard $ + case style of + Block{} -> T.strip (T.pack ln) `notElem` ["{-", "-}", ""] + _ -> not $ all C.isSpace ln + pure (ln, pos) + +{- | Normal line is a line neither a example nor prop. + Empty line is normal. +-} +normalLineP :: + -- | True if Literate Haskell + Bool -> + CommentStyle -> + LineParser (String, Position) +normalLineP isLHS style = do + notFollowedBy + (try $ testSymbol isLHS style) + when (isLHS && is _Block style) $ + void $ count' 0 2 $ char ' ' + consume style + +consume :: CommentStyle -> LineParser (String, Position) +consume style = + case style of + Line -> (,) <$> takeRest <*> getPosition + Block {} -> manyTill_ anySingle (getPosition <* eob) + +getPosition :: (Ord v, TraversableStream s) => ParsecT v s m Position +getPosition = sourcePosToPosition <$> getSourcePos + +-- | Parses example test line. +exampleLineStrP :: + -- | True if Literate Haskell + Bool -> + CommentStyle -> + LineParser (ExampleLine, Position) +exampleLineStrP isLHS style = + try $ + -- FIXME: To comply with existing Extended Eval Plugin Behaviour; + -- it must skip one space after a comment! + -- This prevents Eval Plugin from working on + -- modules with non-standard base indentation-level. + when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') + *> exampleSymbol + *> (first ExampleLine <$> consume style) + +exampleSymbol :: LineParser () +exampleSymbol = + chunk ">>>" *> P.notFollowedBy (char '>') + +propSymbol :: LineParser () +propSymbol = chunk "prop>" *> P.notFollowedBy (char '>') + +-- | Parses prop test line. +propLineStrP :: + -- | True if Literate HAskell + Bool -> + CommentStyle -> + LineParser (PropLine, Position) +propLineStrP isLHS style = + -- FIXME: To comply with existing Extended Eval Plugin Behaviour; + -- it must skip one space after a comment! + -- This prevents Eval Plugin from working on + -- modules with non-standard base indentation-level. + when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') + *> chunk "prop>" + *> P.notFollowedBy (char '>') + *> (first PropLine <$> consume style) + +-- * Utilities + +{- | +Given a sequence of tokens increasing in their starting position, +groups them into sublists consisting of contiguous tokens; +Two adjacent tokens are considered to be contiguous if + + * line number increases by 1, and + * they have same starting column. + +>>> contiguousGroupOn id [(1,2),(2,2),(3,4),(4,4),(5,4),(7,0),(8,0)] +[(1,2) :| [(2,2)],(3,4) :| [(4,4),(5,4)],(7,0) :| [(8,0)]] +-} +contiguousGroupOn :: (a -> (UInt, UInt)) -> [a] -> [NonEmpty a] +contiguousGroupOn toLineCol = foldr step [] + where + step a [] = [pure a] + step a bss0@((b :| bs) : bss) + | let (aLine, aCol) = toLineCol a + , let (bLine, bCol) = toLineCol b + , aLine + 1 == bLine && aCol == bCol = + (a :| b : bs) : bss + | otherwise = pure a : bss0 + +{- | Given a map from positions, divides them into subgroup + with contiguous line and columns. +-} +groupLineComments :: + Map Range a -> [NonEmpty (Range, a)] +groupLineComments = + contiguousGroupOn (fst >>> view start >>> view line &&& view character) + . Map.toList diff --git a/plugins/hls-eval-plugin/test/info-util/InfoUtil.hs b/plugins/hls-eval-plugin/test/info-util/InfoUtil.hs index 01bed8857..4d6912133 100644 --- a/plugins/hls-eval-plugin/test/info-util/InfoUtil.hs +++ b/plugins/hls-eval-plugin/test/info-util/InfoUtil.hs @@ -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 diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index afe9802c1..f452be189 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -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 diff --git a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs index 1c4ecb743..14d31faa2 100644 --- a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs +++ b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs @@ -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 diff --git a/shake-bench/src/Development/Benchmark/Rules.hs b/shake-bench/src/Development/Benchmark/Rules.hs index 2c6d6c7eb..e2bcc9b4c 100644 --- a/shake-bench/src/Development/Benchmark/Rules.hs +++ b/shake-bench/src/Development/Benchmark/Rules.hs @@ -1,704 +1,704 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - -{- | - This module provides a bunch of Shake rules to build multiple revisions of a - project and analyse their performance. - - It assumes a project bench suite composed of examples that runs a fixed set - of experiments on every example - - Your code must implement all of the GetFoo oracles and the IsExample class, - instantiate the Shake rules, and probably 'want' a set of targets. - - The results of the benchmarks and the analysis are recorded in the file - system, using the following structure: - - - ├── binaries - │ └── - │  ├── ghc.path - path to ghc used to build the executable - │  └── - binary for this version - │  └── commitid - Git commit id for this reference - ├─ - │ ├── results.csv - aggregated results for all the versions - │ └── - │   ├── .gcStats.log - RTS -s output - │   ├── .csv - stats for the experiment - │   ├── .svg - Graph of bytes over elapsed time - │   ├── .diff.svg - idem, including the previous version - │   ├── .heap.svg - Heap profile - │   ├── .log - bench stdout - │   └── results.csv - results of all the experiments for the example - ├── results.csv - aggregated results of all the experiments and versions - └── .svg - graph of bytes over elapsed time, for all the included versions - - For diff graphs, the "previous version" is the preceding entry in the list of versions - in the config file. A possible improvement is to obtain this info via `git rev-list`. - -} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module Development.Benchmark.Rules - ( - buildRules, MkBuildRules(..), - benchRules, MkBenchRules(..), BenchProject(..), ProfilingMode(..), - csvRules, - svgRules, - heapProfileRules, - phonyRules, - allTargetsForExample, - GetExample(..), GetExamples(..), - IsExample(..), RuleResultForExample, - GetExperiments(..), - GetVersions(..), - GetCommitId(..), - GetBuildSystem(..), - BuildSystem(..), findGhcForBuildSystem, - Escaped(..), Unescaped(..), escapeExperiment, unescapeExperiment, - GitCommit - - ) where - -import Control.Applicative -import Control.Lens ((^.)) -import Control.Monad -import Data.Aeson (FromJSON (..), - ToJSON (..), - Value (..), object, - (.!=), (.:?), (.=)) -import Data.Aeson.Lens (_Object) -import Data.Char (isDigit) -import Data.List (find, isInfixOf, - stripPrefix, - transpose) -import Data.List.Extra (lower) -import Data.Maybe (fromMaybe) -import Data.String (fromString) -import Data.Text (Text) -import qualified Data.Text as T -import Development.Shake -import Development.Shake.Classes (Binary, Hashable, - NFData, Typeable) -import GHC.Exts (IsList (toList), - fromList) -import GHC.Generics (Generic) -import GHC.Stack (HasCallStack) -import qualified Graphics.Rendering.Chart.Backend.Diagrams as E -import qualified Graphics.Rendering.Chart.Easy as E -import System.Directory (createDirectoryIfMissing, - findExecutable, - renameFile) -import System.FilePath -import System.Time.Extra (Seconds) -import qualified Text.ParserCombinators.ReadP as P -import Text.Printf -import Text.Read (Read (..), get, - readMaybe, - readP_to_Prec) - -newtype GetExperiments = GetExperiments () deriving newtype (Binary, Eq, Hashable, NFData, Show) -newtype GetVersions = GetVersions () deriving newtype (Binary, Eq, Hashable, NFData, Show) -newtype GetParent = GetParent Text deriving newtype (Binary, Eq, Hashable, NFData, Show) -newtype GetCommitId = GetCommitId String deriving newtype (Binary, Eq, Hashable, NFData, Show) -newtype GetBuildSystem = GetBuildSystem () deriving newtype (Binary, Eq, Hashable, NFData, Show) -newtype GetExample = GetExample String deriving newtype (Binary, Eq, Hashable, NFData, Show) -newtype GetExamples = GetExamples () deriving newtype (Binary, Eq, Hashable, NFData, Show) - -type instance RuleResult GetExperiments = [Unescaped String] -type instance RuleResult GetVersions = [GitCommit] -type instance RuleResult GetParent = Text -type instance RuleResult GetCommitId = String -type instance RuleResult GetBuildSystem = BuildSystem - -type RuleResultForExample e = - ( RuleResult GetExample ~ Maybe e - , RuleResult GetExamples ~ [e] - , IsExample e) - --- | Knowledge needed to run an example -class (Binary e, Eq e, Hashable e, NFData e, Show e, Typeable e) => IsExample e where - getExampleName :: e -> String - --------------------------------------------------------------------------------- - -allTargetsForExample :: IsExample e => ProfilingMode -> FilePath -> e -> Action [FilePath] -allTargetsForExample prof baseFolder ex = do - experiments <- askOracle $ GetExperiments () - versions <- askOracle $ GetVersions () - let buildFolder = baseFolder profilingPath prof - return $ - [buildFolder getExampleName ex "results.csv"] - ++ [ buildFolder getExampleName ex escaped (escapeExperiment e) <.> "svg" - | e <- experiments - ] - ++ [ buildFolder - getExampleName ex - T.unpack (humanName ver) - escaped (escapeExperiment e) <.> mode - | e <- experiments, - ver <- versions, - mode <- ["svg", "diff.svg"] ++ ["heap.svg" | prof /= NoProfiling] - ] - -allBinaries :: FilePath -> String -> Action [FilePath] -allBinaries buildFolder executableName = do - versions <- askOracle $ GetVersions () - return $ - [ buildFolder "binaries" T.unpack (humanName ver) executableName - | ver <- versions] - --- | Generate a set of phony rules: --- * all --- * for each example -phonyRules - :: (Traversable t, IsExample e) - => String -- ^ prefix - -> String -- ^ Executable name - -> ProfilingMode - -> FilePath - -> t e - -> Rules () -phonyRules prefix executableName prof buildFolder examples = do - forM_ examples $ \ex -> - phony (prefix <> getExampleName ex) $ need =<< - allTargetsForExample prof buildFolder ex - phony (prefix <> "all") $ do - exampleTargets <- forM examples $ \ex -> - allTargetsForExample prof buildFolder ex - need $ (buildFolder profilingPath prof "results.csv") - : concat exampleTargets - phony (prefix <> "all-binaries") $ need =<< allBinaries buildFolder executableName --------------------------------------------------------------------------------- -type OutputFolder = FilePath - -data MkBuildRules buildSystem = MkBuildRules - { -- | Return the path to the GHC executable to use for the project found in the cwd - findGhc :: buildSystem -> FilePath -> IO FilePath - -- | Name of the binary produced by 'buildProject' - , executableName :: String - -- | An action that captures the source dependencies, used for the HEAD build - , projectDepends :: Action () - -- | Build the project found in the cwd and save the build artifacts in the output folder - , buildProject :: buildSystem - -> [CmdOption] - -> OutputFolder - -> Action () - } - --- | Rules that drive a build system to build various revisions of a project -buildRules :: FilePattern -> MkBuildRules BuildSystem -> Rules () --- TODO generalize BuildSystem -buildRules build MkBuildRules{..} = do - -- query git for the commitid for a version - build -/- "binaries/*/commitid" %> \out -> do - alwaysRerun - - let [_,_,ver,_] = splitDirectories out - mbEntry <- find ((== T.pack ver) . humanName) <$> askOracle (GetVersions ()) - let gitThing :: String - gitThing = maybe ver (T.unpack . gitName) mbEntry - Stdout commitid <- command [] "git" ["rev-list", "-n", "1", gitThing] - writeFileChanged out $ init commitid - - -- build rules for HEAD - priority 10 $ [ build -/- "binaries/HEAD/" <> executableName - , build -/- "binaries/HEAD/ghc.path" - ] - &%> \[out, ghcpath] -> do - projectDepends - liftIO $ createDirectoryIfMissing True $ dropFileName out - buildSystem <- askOracle $ GetBuildSystem () - buildProject buildSystem [Cwd "."] (takeDirectory out) - ghcLoc <- liftIO $ findGhc buildSystem "." - writeFile' ghcpath ghcLoc - - -- build rules for non HEAD revisions - [build -/- "binaries/*/" <> executableName - ,build -/- "binaries/*/ghc.path" - ] &%> \[out, ghcPath] -> do - let [_, _binaries, ver, _] = splitDirectories out - liftIO $ createDirectoryIfMissing True $ dropFileName out - commitid <- readFile' $ takeDirectory out "commitid" - cmd_ $ "git worktree add bench-temp-" ++ ver ++ " " ++ commitid - buildSystem <- askOracle $ GetBuildSystem () - flip actionFinally (cmd_ ("git worktree remove bench-temp-" <> ver <> " --force" :: String)) $ do - ghcLoc <- liftIO $ findGhc buildSystem ver - buildProject buildSystem [Cwd $ "bench-temp-" <> ver] (".." takeDirectory out) - writeFile' ghcPath ghcLoc - --------------------------------------------------------------------------------- -data MkBenchRules buildSystem example = forall setup. MkBenchRules - { - -- | Workaround for Shake not allowing to call 'askOracle' from 'benchProject - setupProject :: Action setup - -- | An action that invokes the executable to run the benchmark - , benchProject :: setup -> buildSystem -> [CmdOption] -> BenchProject example -> Action () - -- | An action that performs any necessary warmup. Will only be invoked once - , warmupProject :: buildSystem -> FilePath -> [CmdOption] -> example -> Action () - -- | Name of the executable to benchmark. Should match the one used to 'MkBuildRules' - , executableName :: String - } - -data BenchProject example = BenchProject - { outcsv :: FilePath -- ^ where to save the CSV output - , exePath :: FilePath -- ^ where to find the executable for benchmarking - , exeExtraArgs :: [String] -- ^ extra args for the executable - , example :: example -- ^ example to benchmark - , experiment :: Escaped String -- ^ experiment to run - } - -data ProfilingMode = NoProfiling | CheapHeapProfiling Seconds - deriving (Eq) - -profilingP :: String -> Maybe ProfilingMode -profilingP "unprofiled" = Just NoProfiling -profilingP inp | Just delay <- stripPrefix "profiled-" inp, Just i <- readMaybe delay = Just $ CheapHeapProfiling i -profilingP _ = Nothing - -profilingPath :: ProfilingMode -> FilePath -profilingPath NoProfiling = "unprofiled" -profilingPath (CheapHeapProfiling i) = "profiled-" <> show i - --- TODO generalize BuildSystem -benchRules :: RuleResultForExample example => FilePattern -> MkBenchRules BuildSystem example -> Rules () -benchRules build MkBenchRules{..} = do - - benchResource <- newResource "ghcide-bench" 1 - -- warmup an example - build -/- "binaries/*/*.warmup" %> \out -> do - let [_, _, ver, exampleName] = splitDirectories (dropExtension out) - let exePath = build "binaries" ver executableName - ghcPath = build "binaries" ver "ghc.path" - need [exePath, ghcPath] - buildSystem <- askOracle $ GetBuildSystem () - example <- fromMaybe (error $ "Unknown example " <> exampleName) - <$> askOracle (GetExample exampleName) - let exeExtraArgs = [] - outcsv = "" - experiment = Escaped "hover" - withResource benchResource 1 $ warmupProject buildSystem exePath - [ EchoStdout False, - FileStdout out, - RemEnv "NIX_GHC_LIBDIR", - RemEnv "GHC_PACKAGE_PATH", - AddPath [takeDirectory ghcPath, "."] [] - ] - example - -- run an experiment - priority 0 $ - [ build -/- "*/*/*/*.csv", - build -/- "*/*/*/*.gcStats.log", - build -/- "*/*/*/*.output.log", - build -/- "*/*/*/*.eventlog", - build -/- "*/*/*/*.hp" - ] &%> \[outcsv, outGc, outLog, outEventlog, outHp] -> do - let [_, flavour, exampleName, ver, exp] = splitDirectories outcsv - prof = fromMaybe (error $ "Not a valid profiling mode: " <> flavour) $ profilingP flavour - example <- fromMaybe (error $ "Unknown example " <> exampleName) - <$> askOracle (GetExample exampleName) - buildSystem <- askOracle $ GetBuildSystem () - setupRes <- setupProject - liftIO $ createDirectoryIfMissing True $ dropFileName outcsv - let exePath = build "binaries" ver executableName - exeExtraArgs = - [ "+RTS" - , "-l" - , "-S" <> outGc] - ++ concat - [[ "-h" - , "-i" <> show i - , "-qg"] - | CheapHeapProfiling i <- [prof]] - ++ ["-RTS"] - ghcPath = build "binaries" ver "ghc.path" - warmupPath = build "binaries" ver exampleName <.> "warmup" - experiment = Escaped $ dropExtension exp - need [exePath, ghcPath, warmupPath] - ghcPath <- readFile' ghcPath - withResource benchResource 1 $ do - benchProject setupRes buildSystem - [ EchoStdout False, - FileStdout outLog, - RemEnv "NIX_GHC_LIBDIR", - RemEnv "GHC_PACKAGE_PATH", - AddPath [takeDirectory ghcPath, "."] [] - ] - BenchProject {..} - liftIO $ renameFile "ghcide.eventlog" outEventlog - liftIO $ case prof of - CheapHeapProfiling{} -> renameFile "ghcide.hp" outHp - NoProfiling -> writeFile outHp dummyHp - - -- extend csv output with allocation data - csvContents <- liftIO $ lines <$> readFile outcsv - let header = head csvContents - results = tail csvContents - header' = header <> ", maxResidency, allocatedBytes" - results' <- forM results $ \row -> do - (maxResidency, allocations) <- liftIO - (parseMaxResidencyAndAllocations <$> readFile outGc) - return $ printf "%s, %s, %s" row (showMB maxResidency) (showMB allocations) - let csvContents' = header' : results' - writeFileLines outcsv csvContents' - where - showMB :: Int -> String - showMB x = show (x `div` 2^(20::Int)) <> "MB" - --- Parse the max residency and allocations in RTS -s output -parseMaxResidencyAndAllocations :: String -> (Int, Int) -parseMaxResidencyAndAllocations input = - (f "maximum residency", f "bytes allocated in the heap") - where - inps = reverse $ lines input - f label = case find (label `isInfixOf`) inps of - Just l -> read $ filter isDigit $ head $ words l - Nothing -> -1 - - --------------------------------------------------------------------------------- - --- | Rules to aggregate the CSV output of individual experiments -csvRules :: forall example . RuleResultForExample example => FilePattern -> Rules () -csvRules build = do - -- build results for every experiment*example - build -/- "*/*/*/results.csv" %> \out -> do - experiments <- askOracle $ GetExperiments () - - let allResultFiles = [takeDirectory out escaped (escapeExperiment e) <.> "csv" | e <- experiments] - allResults <- traverse readFileLines allResultFiles - - let header = head $ head allResults - results = map tail allResults - writeFileChanged out $ unlines $ header : concat results - - -- aggregate all experiments for an example - build -/- "*/*/results.csv" %> \out -> do - versions <- map (T.unpack . humanName) <$> askOracle (GetVersions ()) - let allResultFiles = [takeDirectory out v "results.csv" | v <- versions] - - allResults <- traverse readFileLines allResultFiles - - let header = head $ head allResults - results = map tail allResults - header' = "version, " <> header - results' = zipWith (\v -> map (\l -> v <> ", " <> l)) versions results - - writeFileChanged out $ unlines $ header' : interleave results' - - -- aggregate all examples - build -/- "*/results.csv" %> \out -> do - examples <- map (getExampleName @example) <$> askOracle (GetExamples ()) - let allResultFiles = [takeDirectory out e "results.csv" | e <- examples] - - allResults <- traverse readFileLines allResultFiles - - let header = head $ head allResults - results = map tail allResults - header' = "example, " <> header - results' = zipWith (\e -> map (\l -> e <> ", " <> l)) examples results - - writeFileChanged out $ unlines $ header' : concat results' - --------------------------------------------------------------------------------- - --- | Rules to produce charts for the GC stats -svgRules :: FilePattern -> Rules () -svgRules build = do - void $ addOracle $ \(GetParent name) -> findPrev name <$> askOracle (GetVersions ()) - -- chart GC stats for an experiment on a given revision - priority 1 $ - build -/- "*/*/*/*.svg" %> \out -> do - let [_, _, _example, ver, _exp] = splitDirectories out - runLog <- loadRunLog (Escaped $ replaceExtension out "csv") ver - let diagram = Diagram Live [runLog] title - title = ver <> " live bytes over time" - plotDiagram True diagram out - - -- chart of GC stats for an experiment on this and the previous revision - priority 2 $ - build -/- "*/*/*/*.diff.svg" %> \out -> do - let [b, flav, example, ver, exp_] = splitDirectories out - exp = Escaped $ dropExtension2 exp_ - prev <- fmap T.unpack $ askOracle $ GetParent $ T.pack ver - - runLog <- loadRunLog (Escaped $ replaceExtension (dropExtension out) "csv") ver - runLogPrev <- loadRunLog (Escaped $ joinPath [b,flav, example, prev, replaceExtension (dropExtension exp_) "csv"]) prev - - let diagram = Diagram Live [runLog, runLogPrev] title - title = show (unescapeExperiment exp) <> " - live bytes over time compared" - plotDiagram True diagram out - - -- aggregated chart of GC stats for all the revisions - build -/- "*/*/*.svg" %> \out -> do - let exp = Escaped $ dropExtension $ takeFileName out - versions <- askOracle $ GetVersions () - - runLogs <- forM (filter include versions) $ \v -> do - let v' = T.unpack (humanName v) - loadRunLog (Escaped $ takeDirectory out v' replaceExtension (takeFileName out) "csv") v' - - let diagram = Diagram Live runLogs title - title = show (unescapeExperiment exp) <> " - live bytes over time" - plotDiagram False diagram out - -heapProfileRules :: FilePattern -> Rules () -heapProfileRules build = do - priority 3 $ - build -/- "*/*/*/*.heap.svg" %> \out -> do - let hpFile = dropExtension2 out <.> "hp" - need [hpFile] - cmd_ ("hp2pretty" :: String) [hpFile] - liftIO $ renameFile (dropExtension hpFile <.> "svg") out - -dropExtension2 :: FilePath -> FilePath -dropExtension2 = dropExtension . dropExtension --------------------------------------------------------------------------------- --------------------------------------------------------------------------------- - --- | Default build system that handles Cabal and Stack -data BuildSystem = Cabal | Stack - deriving (Eq, Read, Show, Generic) - deriving (Binary, Hashable, NFData) - -findGhcForBuildSystem :: BuildSystem -> FilePath -> IO FilePath -findGhcForBuildSystem Cabal _cwd = - liftIO $ fromMaybe (error "ghc is not in the PATH") <$> findExecutable "ghc" -findGhcForBuildSystem Stack cwd = do - Stdout ghcLoc <- cmd [Cwd cwd] ("stack exec which ghc" :: String) - return ghcLoc - -instance FromJSON BuildSystem where - parseJSON x = fromString . lower <$> parseJSON x - where - fromString "stack" = Stack - fromString "cabal" = Cabal - fromString other = error $ "Unknown build system: " <> other - -instance ToJSON BuildSystem where - toJSON = toJSON . show - --------------------------------------------------------------------------------- - -data GitCommit = GitCommit - { -- | A git hash, tag or branch name (e.g. v0.1.0) - gitName :: Text, - -- | A human understandable name (e.g. fix-collisions-leak) - name :: Maybe Text, - -- | The human understandable name of the parent, if specified explicitly - parent :: Maybe Text, - -- | Whether to include this version in the top chart - include :: Bool - } - deriving (Binary, Eq, Hashable, Generic, NFData, Show) - -instance FromJSON GitCommit where - parseJSON (String s) = pure $ GitCommit s Nothing Nothing True - parseJSON o@(Object _) = do - let keymap = o ^. _Object - case toList keymap of - [(name, String gitName)] -> pure $ GitCommit gitName (Just name) Nothing True - [(name, Object props)] -> - GitCommit - <$> props .:? "git" .!= name - <*> pure (Just name) - <*> props .:? "parent" - <*> props .:? "include" .!= True - _ -> empty - parseJSON _ = empty - -instance ToJSON GitCommit where - toJSON GitCommit {..} = - case name of - Nothing -> String gitName - Just n -> object [fromString (T.unpack n) .= String gitName] - -humanName :: GitCommit -> Text -humanName GitCommit {..} = fromMaybe gitName name - -findPrev :: Text -> [GitCommit] -> Text -findPrev name (x : y : xx) - | humanName y == name = humanName x - | otherwise = findPrev name (y : xx) -findPrev name _ = name - --------------------------------------------------------------------------------- - --- | A line in the output of -S -data Frame = Frame - { allocated, copied, live :: !Int, - user, elapsed, totUser, totElapsed :: !Double, - generation :: !Int - } - deriving (Show) - -instance Read Frame where - readPrec = do - spaces - allocated <- readPrec @Int <* spaces - copied <- readPrec @Int <* spaces - live <- readPrec @Int <* spaces - user <- readPrec @Double <* spaces - elapsed <- readPrec @Double <* spaces - totUser <- readPrec @Double <* spaces - totElapsed <- readPrec @Double <* spaces - _ <- readPrec @Int <* spaces - _ <- readPrec @Int <* spaces - "(Gen: " <- replicateM 7 get - generation <- readPrec @Int - ')' <- get - return Frame {..} - where - spaces = readP_to_Prec $ const P.skipSpaces - --- | A file path containing the output of -S for a given run -data RunLog = RunLog - { runVersion :: !String, - runFrames :: ![Frame], - runSuccess :: !Bool - } - -loadRunLog :: HasCallStack => Escaped FilePath -> String -> Action RunLog -loadRunLog (Escaped csv_fp) ver = do - let log_fp = replaceExtension csv_fp "gcStats.log" - log <- readFileLines log_fp - csv <- readFileLines csv_fp - let frames = - [ f - | l <- log, - Just f <- [readMaybe l], - -- filter out gen 0 events as there are too many - generation f == 1 - ] - -- TODO this assumes a certain structure in the CSV file - success = case map (T.split (== ',') . T.pack) csv of - [_header, _name:s:_] | Just s <- readMaybe (T.unpack s) -> s - _ -> error $ "Cannot parse: " <> csv_fp - return $ RunLog ver frames success - --------------------------------------------------------------------------------- - -data TraceMetric = Allocated | Copied | Live | User | Elapsed - deriving (Generic, Enum, Bounded, Read) - -instance Show TraceMetric where - show Allocated = "Allocated bytes" - show Copied = "Copied bytes" - show Live = "Live bytes" - show User = "User time" - show Elapsed = "Elapsed time" - -frameMetric :: TraceMetric -> Frame -> Double -frameMetric Allocated = fromIntegral . allocated -frameMetric Copied = fromIntegral . copied -frameMetric Live = fromIntegral . live -frameMetric Elapsed = elapsed -frameMetric User = user - -data Diagram = Diagram - { traceMetric :: TraceMetric, - runLogs :: [RunLog], - title :: String - } - deriving (Generic) - -plotDiagram :: Bool -> Diagram -> FilePath -> Action () -plotDiagram includeFailed t@Diagram {traceMetric, runLogs} out = do - let extract = frameMetric traceMetric - liftIO $ E.toFile E.def out $ do - E.layout_title E..= title t - E.setColors myColors - forM_ runLogs $ \rl -> - when (includeFailed || runSuccess rl) $ E.plot $ do - lplot <- E.line - (runVersion rl ++ if runSuccess rl then "" else " (FAILED)") - [ [ (totElapsed f, extract f) - | f <- runFrames rl - ] - ] - return (lplot E.& E.plot_lines_style . E.line_width E.*~ 2) - --------------------------------------------------------------------------------- - -newtype Escaped a = Escaped {escaped :: a} - -newtype Unescaped a = Unescaped {unescaped :: a} - deriving newtype (Show, FromJSON, ToJSON, Eq, NFData, Binary, Hashable) - -escapeExperiment :: Unescaped String -> Escaped String -escapeExperiment = Escaped . map f . unescaped - where - f ' ' = '_' - f other = other - -unescapeExperiment :: Escaped String -> Unescaped String -unescapeExperiment = Unescaped . map f . escaped - where - f '_' = ' ' - f other = other - --------------------------------------------------------------------------------- - -(-/-) :: FilePattern -> FilePattern -> FilePattern -a -/- b = a <> "/" <> b - -interleave :: [[a]] -> [a] -interleave = concat . transpose - --------------------------------------------------------------------------------- - -myColors :: [E.AlphaColour Double] -myColors = map E.opaque - [ E.blue - , E.green - , E.red - , E.orange - , E.yellow - , E.violet - , E.black - , E.gold - , E.brown - , E.hotpink - , E.aliceblue - , E.aqua - , E.beige - , E.bisque - , E.blueviolet - , E.burlywood - , E.cadetblue - , E.chartreuse - , E.coral - , E.crimson - , E.darkblue - , E.darkgray - , E.darkgreen - , E.darkkhaki - , E.darkmagenta - , E.deeppink - , E.dodgerblue - , E.firebrick - , E.forestgreen - , E.fuchsia - , E.greenyellow - , E.lightsalmon - , E.seagreen - , E.olive - , E.sandybrown - , E.sienna - , E.peru - ] - -dummyHp :: String -dummyHp = - "JOB \"ghcide\" \ - \DATE \"Sun Jan 31 09:30 2021\" \ - \SAMPLE_UNIT \"seconds\" \ - \VALUE_UNIT \"bytes\" \ - \BEGIN_SAMPLE 0.000000 \ - \END_SAMPLE 0.000000" +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +{- | + This module provides a bunch of Shake rules to build multiple revisions of a + project and analyse their performance. + + It assumes a project bench suite composed of examples that runs a fixed set + of experiments on every example + + Your code must implement all of the GetFoo oracles and the IsExample class, + instantiate the Shake rules, and probably 'want' a set of targets. + + The results of the benchmarks and the analysis are recorded in the file + system, using the following structure: + + + ├── binaries + │ └── + │  ├── ghc.path - path to ghc used to build the executable + │  └── - binary for this version + │  └── commitid - Git commit id for this reference + ├─ + │ ├── results.csv - aggregated results for all the versions + │ └── + │   ├── .gcStats.log - RTS -s output + │   ├── .csv - stats for the experiment + │   ├── .svg - Graph of bytes over elapsed time + │   ├── .diff.svg - idem, including the previous version + │   ├── .heap.svg - Heap profile + │   ├── .log - bench stdout + │   └── results.csv - results of all the experiments for the example + ├── results.csv - aggregated results of all the experiments and versions + └── .svg - graph of bytes over elapsed time, for all the included versions + + For diff graphs, the "previous version" is the preceding entry in the list of versions + in the config file. A possible improvement is to obtain this info via `git rev-list`. + -} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +module Development.Benchmark.Rules + ( + buildRules, MkBuildRules(..), + benchRules, MkBenchRules(..), BenchProject(..), ProfilingMode(..), + csvRules, + svgRules, + heapProfileRules, + phonyRules, + allTargetsForExample, + GetExample(..), GetExamples(..), + IsExample(..), RuleResultForExample, + GetExperiments(..), + GetVersions(..), + GetCommitId(..), + GetBuildSystem(..), + BuildSystem(..), findGhcForBuildSystem, + Escaped(..), Unescaped(..), escapeExperiment, unescapeExperiment, + GitCommit + + ) where + +import Control.Applicative +import Control.Lens ((^.)) +import Control.Monad +import Data.Aeson (FromJSON (..), + ToJSON (..), + Value (..), object, + (.!=), (.:?), (.=)) +import Data.Aeson.Lens (_Object) +import Data.Char (isDigit) +import Data.List (find, isInfixOf, + stripPrefix, + transpose) +import Data.List.Extra (lower) +import Data.Maybe (fromMaybe) +import Data.String (fromString) +import Data.Text (Text) +import qualified Data.Text as T +import Development.Shake +import Development.Shake.Classes (Binary, Hashable, + NFData, Typeable) +import GHC.Exts (IsList (toList), + fromList) +import GHC.Generics (Generic) +import GHC.Stack (HasCallStack) +import qualified Graphics.Rendering.Chart.Backend.Diagrams as E +import qualified Graphics.Rendering.Chart.Easy as E +import System.Directory (createDirectoryIfMissing, + findExecutable, + renameFile) +import System.FilePath +import System.Time.Extra (Seconds) +import qualified Text.ParserCombinators.ReadP as P +import Text.Printf +import Text.Read (Read (..), get, + readMaybe, + readP_to_Prec) + +newtype GetExperiments = GetExperiments () deriving newtype (Binary, Eq, Hashable, NFData, Show) +newtype GetVersions = GetVersions () deriving newtype (Binary, Eq, Hashable, NFData, Show) +newtype GetParent = GetParent Text deriving newtype (Binary, Eq, Hashable, NFData, Show) +newtype GetCommitId = GetCommitId String deriving newtype (Binary, Eq, Hashable, NFData, Show) +newtype GetBuildSystem = GetBuildSystem () deriving newtype (Binary, Eq, Hashable, NFData, Show) +newtype GetExample = GetExample String deriving newtype (Binary, Eq, Hashable, NFData, Show) +newtype GetExamples = GetExamples () deriving newtype (Binary, Eq, Hashable, NFData, Show) + +type instance RuleResult GetExperiments = [Unescaped String] +type instance RuleResult GetVersions = [GitCommit] +type instance RuleResult GetParent = Text +type instance RuleResult GetCommitId = String +type instance RuleResult GetBuildSystem = BuildSystem + +type RuleResultForExample e = + ( RuleResult GetExample ~ Maybe e + , RuleResult GetExamples ~ [e] + , IsExample e) + +-- | Knowledge needed to run an example +class (Binary e, Eq e, Hashable e, NFData e, Show e, Typeable e) => IsExample e where + getExampleName :: e -> String + +-------------------------------------------------------------------------------- + +allTargetsForExample :: IsExample e => ProfilingMode -> FilePath -> e -> Action [FilePath] +allTargetsForExample prof baseFolder ex = do + experiments <- askOracle $ GetExperiments () + versions <- askOracle $ GetVersions () + let buildFolder = baseFolder profilingPath prof + return $ + [buildFolder getExampleName ex "results.csv"] + ++ [ buildFolder getExampleName ex escaped (escapeExperiment e) <.> "svg" + | e <- experiments + ] + ++ [ buildFolder + getExampleName ex + T.unpack (humanName ver) + escaped (escapeExperiment e) <.> mode + | e <- experiments, + ver <- versions, + mode <- ["svg", "diff.svg"] ++ ["heap.svg" | prof /= NoProfiling] + ] + +allBinaries :: FilePath -> String -> Action [FilePath] +allBinaries buildFolder executableName = do + versions <- askOracle $ GetVersions () + return $ + [ buildFolder "binaries" T.unpack (humanName ver) executableName + | ver <- versions] + +-- | Generate a set of phony rules: +-- * all +-- * for each example +phonyRules + :: (Traversable t, IsExample e) + => String -- ^ prefix + -> String -- ^ Executable name + -> ProfilingMode + -> FilePath + -> t e + -> Rules () +phonyRules prefix executableName prof buildFolder examples = do + forM_ examples $ \ex -> + phony (prefix <> getExampleName ex) $ need =<< + allTargetsForExample prof buildFolder ex + phony (prefix <> "all") $ do + exampleTargets <- forM examples $ \ex -> + allTargetsForExample prof buildFolder ex + need $ (buildFolder profilingPath prof "results.csv") + : concat exampleTargets + phony (prefix <> "all-binaries") $ need =<< allBinaries buildFolder executableName +-------------------------------------------------------------------------------- +type OutputFolder = FilePath + +data MkBuildRules buildSystem = MkBuildRules + { -- | Return the path to the GHC executable to use for the project found in the cwd + findGhc :: buildSystem -> FilePath -> IO FilePath + -- | Name of the binary produced by 'buildProject' + , executableName :: String + -- | An action that captures the source dependencies, used for the HEAD build + , projectDepends :: Action () + -- | Build the project found in the cwd and save the build artifacts in the output folder + , buildProject :: buildSystem + -> [CmdOption] + -> OutputFolder + -> Action () + } + +-- | Rules that drive a build system to build various revisions of a project +buildRules :: FilePattern -> MkBuildRules BuildSystem -> Rules () +-- TODO generalize BuildSystem +buildRules build MkBuildRules{..} = do + -- query git for the commitid for a version + build -/- "binaries/*/commitid" %> \out -> do + alwaysRerun + + let [_,_,ver,_] = splitDirectories out + mbEntry <- find ((== T.pack ver) . humanName) <$> askOracle (GetVersions ()) + let gitThing :: String + gitThing = maybe ver (T.unpack . gitName) mbEntry + Stdout commitid <- command [] "git" ["rev-list", "-n", "1", gitThing] + writeFileChanged out $ init commitid + + -- build rules for HEAD + priority 10 $ [ build -/- "binaries/HEAD/" <> executableName + , build -/- "binaries/HEAD/ghc.path" + ] + &%> \[out, ghcpath] -> do + projectDepends + liftIO $ createDirectoryIfMissing True $ dropFileName out + buildSystem <- askOracle $ GetBuildSystem () + buildProject buildSystem [Cwd "."] (takeDirectory out) + ghcLoc <- liftIO $ findGhc buildSystem "." + writeFile' ghcpath ghcLoc + + -- build rules for non HEAD revisions + [build -/- "binaries/*/" <> executableName + ,build -/- "binaries/*/ghc.path" + ] &%> \[out, ghcPath] -> do + let [_, _binaries, ver, _] = splitDirectories out + liftIO $ createDirectoryIfMissing True $ dropFileName out + commitid <- readFile' $ takeDirectory out "commitid" + cmd_ $ "git worktree add bench-temp-" ++ ver ++ " " ++ commitid + buildSystem <- askOracle $ GetBuildSystem () + flip actionFinally (cmd_ ("git worktree remove bench-temp-" <> ver <> " --force" :: String)) $ do + ghcLoc <- liftIO $ findGhc buildSystem ver + buildProject buildSystem [Cwd $ "bench-temp-" <> ver] (".." takeDirectory out) + writeFile' ghcPath ghcLoc + +-------------------------------------------------------------------------------- +data MkBenchRules buildSystem example = forall setup. MkBenchRules + { + -- | Workaround for Shake not allowing to call 'askOracle' from 'benchProject + setupProject :: Action setup + -- | An action that invokes the executable to run the benchmark + , benchProject :: setup -> buildSystem -> [CmdOption] -> BenchProject example -> Action () + -- | An action that performs any necessary warmup. Will only be invoked once + , warmupProject :: buildSystem -> FilePath -> [CmdOption] -> example -> Action () + -- | Name of the executable to benchmark. Should match the one used to 'MkBuildRules' + , executableName :: String + } + +data BenchProject example = BenchProject + { outcsv :: FilePath -- ^ where to save the CSV output + , exePath :: FilePath -- ^ where to find the executable for benchmarking + , exeExtraArgs :: [String] -- ^ extra args for the executable + , example :: example -- ^ example to benchmark + , experiment :: Escaped String -- ^ experiment to run + } + +data ProfilingMode = NoProfiling | CheapHeapProfiling Seconds + deriving (Eq) + +profilingP :: String -> Maybe ProfilingMode +profilingP "unprofiled" = Just NoProfiling +profilingP inp | Just delay <- stripPrefix "profiled-" inp, Just i <- readMaybe delay = Just $ CheapHeapProfiling i +profilingP _ = Nothing + +profilingPath :: ProfilingMode -> FilePath +profilingPath NoProfiling = "unprofiled" +profilingPath (CheapHeapProfiling i) = "profiled-" <> show i + +-- TODO generalize BuildSystem +benchRules :: RuleResultForExample example => FilePattern -> MkBenchRules BuildSystem example -> Rules () +benchRules build MkBenchRules{..} = do + + benchResource <- newResource "ghcide-bench" 1 + -- warmup an example + build -/- "binaries/*/*.warmup" %> \out -> do + let [_, _, ver, exampleName] = splitDirectories (dropExtension out) + let exePath = build "binaries" ver executableName + ghcPath = build "binaries" ver "ghc.path" + need [exePath, ghcPath] + buildSystem <- askOracle $ GetBuildSystem () + example <- fromMaybe (error $ "Unknown example " <> exampleName) + <$> askOracle (GetExample exampleName) + let exeExtraArgs = [] + outcsv = "" + experiment = Escaped "hover" + withResource benchResource 1 $ warmupProject buildSystem exePath + [ EchoStdout False, + FileStdout out, + RemEnv "NIX_GHC_LIBDIR", + RemEnv "GHC_PACKAGE_PATH", + AddPath [takeDirectory ghcPath, "."] [] + ] + example + -- run an experiment + priority 0 $ + [ build -/- "*/*/*/*.csv", + build -/- "*/*/*/*.gcStats.log", + build -/- "*/*/*/*.output.log", + build -/- "*/*/*/*.eventlog", + build -/- "*/*/*/*.hp" + ] &%> \[outcsv, outGc, outLog, outEventlog, outHp] -> do + let [_, flavour, exampleName, ver, exp] = splitDirectories outcsv + prof = fromMaybe (error $ "Not a valid profiling mode: " <> flavour) $ profilingP flavour + example <- fromMaybe (error $ "Unknown example " <> exampleName) + <$> askOracle (GetExample exampleName) + buildSystem <- askOracle $ GetBuildSystem () + setupRes <- setupProject + liftIO $ createDirectoryIfMissing True $ dropFileName outcsv + let exePath = build "binaries" ver executableName + exeExtraArgs = + [ "+RTS" + , "-l" + , "-S" <> outGc] + ++ concat + [[ "-h" + , "-i" <> show i + , "-qg"] + | CheapHeapProfiling i <- [prof]] + ++ ["-RTS"] + ghcPath = build "binaries" ver "ghc.path" + warmupPath = build "binaries" ver exampleName <.> "warmup" + experiment = Escaped $ dropExtension exp + need [exePath, ghcPath, warmupPath] + ghcPath <- readFile' ghcPath + withResource benchResource 1 $ do + benchProject setupRes buildSystem + [ EchoStdout False, + FileStdout outLog, + RemEnv "NIX_GHC_LIBDIR", + RemEnv "GHC_PACKAGE_PATH", + AddPath [takeDirectory ghcPath, "."] [] + ] + BenchProject {..} + liftIO $ renameFile "ghcide.eventlog" outEventlog + liftIO $ case prof of + CheapHeapProfiling{} -> renameFile "ghcide.hp" outHp + NoProfiling -> writeFile outHp dummyHp + + -- extend csv output with allocation data + csvContents <- liftIO $ lines <$> readFile outcsv + let header = head csvContents + results = tail csvContents + header' = header <> ", maxResidency, allocatedBytes" + results' <- forM results $ \row -> do + (maxResidency, allocations) <- liftIO + (parseMaxResidencyAndAllocations <$> readFile outGc) + return $ printf "%s, %s, %s" row (showMB maxResidency) (showMB allocations) + let csvContents' = header' : results' + writeFileLines outcsv csvContents' + where + showMB :: Int -> String + showMB x = show (x `div` 2^(20::Int)) <> "MB" + +-- Parse the max residency and allocations in RTS -s output +parseMaxResidencyAndAllocations :: String -> (Int, Int) +parseMaxResidencyAndAllocations input = + (f "maximum residency", f "bytes allocated in the heap") + where + inps = reverse $ lines input + f label = case find (label `isInfixOf`) inps of + Just l -> read $ filter isDigit $ head $ words l + Nothing -> -1 + + +-------------------------------------------------------------------------------- + +-- | Rules to aggregate the CSV output of individual experiments +csvRules :: forall example . RuleResultForExample example => FilePattern -> Rules () +csvRules build = do + -- build results for every experiment*example + build -/- "*/*/*/results.csv" %> \out -> do + experiments <- askOracle $ GetExperiments () + + let allResultFiles = [takeDirectory out escaped (escapeExperiment e) <.> "csv" | e <- experiments] + allResults <- traverse readFileLines allResultFiles + + let header = head $ head allResults + results = map tail allResults + writeFileChanged out $ unlines $ header : concat results + + -- aggregate all experiments for an example + build -/- "*/*/results.csv" %> \out -> do + versions <- map (T.unpack . humanName) <$> askOracle (GetVersions ()) + let allResultFiles = [takeDirectory out v "results.csv" | v <- versions] + + allResults <- traverse readFileLines allResultFiles + + let header = head $ head allResults + results = map tail allResults + header' = "version, " <> header + results' = zipWith (\v -> map (\l -> v <> ", " <> l)) versions results + + writeFileChanged out $ unlines $ header' : interleave results' + + -- aggregate all examples + build -/- "*/results.csv" %> \out -> do + examples <- map (getExampleName @example) <$> askOracle (GetExamples ()) + let allResultFiles = [takeDirectory out e "results.csv" | e <- examples] + + allResults <- traverse readFileLines allResultFiles + + let header = head $ head allResults + results = map tail allResults + header' = "example, " <> header + results' = zipWith (\e -> map (\l -> e <> ", " <> l)) examples results + + writeFileChanged out $ unlines $ header' : concat results' + +-------------------------------------------------------------------------------- + +-- | Rules to produce charts for the GC stats +svgRules :: FilePattern -> Rules () +svgRules build = do + void $ addOracle $ \(GetParent name) -> findPrev name <$> askOracle (GetVersions ()) + -- chart GC stats for an experiment on a given revision + priority 1 $ + build -/- "*/*/*/*.svg" %> \out -> do + let [_, _, _example, ver, _exp] = splitDirectories out + runLog <- loadRunLog (Escaped $ replaceExtension out "csv") ver + let diagram = Diagram Live [runLog] title + title = ver <> " live bytes over time" + plotDiagram True diagram out + + -- chart of GC stats for an experiment on this and the previous revision + priority 2 $ + build -/- "*/*/*/*.diff.svg" %> \out -> do + let [b, flav, example, ver, exp_] = splitDirectories out + exp = Escaped $ dropExtension2 exp_ + prev <- fmap T.unpack $ askOracle $ GetParent $ T.pack ver + + runLog <- loadRunLog (Escaped $ replaceExtension (dropExtension out) "csv") ver + runLogPrev <- loadRunLog (Escaped $ joinPath [b,flav, example, prev, replaceExtension (dropExtension exp_) "csv"]) prev + + let diagram = Diagram Live [runLog, runLogPrev] title + title = show (unescapeExperiment exp) <> " - live bytes over time compared" + plotDiagram True diagram out + + -- aggregated chart of GC stats for all the revisions + build -/- "*/*/*.svg" %> \out -> do + let exp = Escaped $ dropExtension $ takeFileName out + versions <- askOracle $ GetVersions () + + runLogs <- forM (filter include versions) $ \v -> do + let v' = T.unpack (humanName v) + loadRunLog (Escaped $ takeDirectory out v' replaceExtension (takeFileName out) "csv") v' + + let diagram = Diagram Live runLogs title + title = show (unescapeExperiment exp) <> " - live bytes over time" + plotDiagram False diagram out + +heapProfileRules :: FilePattern -> Rules () +heapProfileRules build = do + priority 3 $ + build -/- "*/*/*/*.heap.svg" %> \out -> do + let hpFile = dropExtension2 out <.> "hp" + need [hpFile] + cmd_ ("hp2pretty" :: String) [hpFile] + liftIO $ renameFile (dropExtension hpFile <.> "svg") out + +dropExtension2 :: FilePath -> FilePath +dropExtension2 = dropExtension . dropExtension +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- | Default build system that handles Cabal and Stack +data BuildSystem = Cabal | Stack + deriving (Eq, Read, Show, Generic) + deriving (Binary, Hashable, NFData) + +findGhcForBuildSystem :: BuildSystem -> FilePath -> IO FilePath +findGhcForBuildSystem Cabal _cwd = + liftIO $ fromMaybe (error "ghc is not in the PATH") <$> findExecutable "ghc" +findGhcForBuildSystem Stack cwd = do + Stdout ghcLoc <- cmd [Cwd cwd] ("stack exec which ghc" :: String) + return ghcLoc + +instance FromJSON BuildSystem where + parseJSON x = fromString . lower <$> parseJSON x + where + fromString "stack" = Stack + fromString "cabal" = Cabal + fromString other = error $ "Unknown build system: " <> other + +instance ToJSON BuildSystem where + toJSON = toJSON . show + +-------------------------------------------------------------------------------- + +data GitCommit = GitCommit + { -- | A git hash, tag or branch name (e.g. v0.1.0) + gitName :: Text, + -- | A human understandable name (e.g. fix-collisions-leak) + name :: Maybe Text, + -- | The human understandable name of the parent, if specified explicitly + parent :: Maybe Text, + -- | Whether to include this version in the top chart + include :: Bool + } + deriving (Binary, Eq, Hashable, Generic, NFData, Show) + +instance FromJSON GitCommit where + parseJSON (String s) = pure $ GitCommit s Nothing Nothing True + parseJSON o@(Object _) = do + let keymap = o ^. _Object + case toList keymap of + [(name, String gitName)] -> pure $ GitCommit gitName (Just name) Nothing True + [(name, Object props)] -> + GitCommit + <$> props .:? "git" .!= name + <*> pure (Just name) + <*> props .:? "parent" + <*> props .:? "include" .!= True + _ -> empty + parseJSON _ = empty + +instance ToJSON GitCommit where + toJSON GitCommit {..} = + case name of + Nothing -> String gitName + Just n -> object [fromString (T.unpack n) .= String gitName] + +humanName :: GitCommit -> Text +humanName GitCommit {..} = fromMaybe gitName name + +findPrev :: Text -> [GitCommit] -> Text +findPrev name (x : y : xx) + | humanName y == name = humanName x + | otherwise = findPrev name (y : xx) +findPrev name _ = name + +-------------------------------------------------------------------------------- + +-- | A line in the output of -S +data Frame = Frame + { allocated, copied, live :: !Int, + user, elapsed, totUser, totElapsed :: !Double, + generation :: !Int + } + deriving (Show) + +instance Read Frame where + readPrec = do + spaces + allocated <- readPrec @Int <* spaces + copied <- readPrec @Int <* spaces + live <- readPrec @Int <* spaces + user <- readPrec @Double <* spaces + elapsed <- readPrec @Double <* spaces + totUser <- readPrec @Double <* spaces + totElapsed <- readPrec @Double <* spaces + _ <- readPrec @Int <* spaces + _ <- readPrec @Int <* spaces + "(Gen: " <- replicateM 7 get + generation <- readPrec @Int + ')' <- get + return Frame {..} + where + spaces = readP_to_Prec $ const P.skipSpaces + +-- | A file path containing the output of -S for a given run +data RunLog = RunLog + { runVersion :: !String, + runFrames :: ![Frame], + runSuccess :: !Bool + } + +loadRunLog :: HasCallStack => Escaped FilePath -> String -> Action RunLog +loadRunLog (Escaped csv_fp) ver = do + let log_fp = replaceExtension csv_fp "gcStats.log" + log <- readFileLines log_fp + csv <- readFileLines csv_fp + let frames = + [ f + | l <- log, + Just f <- [readMaybe l], + -- filter out gen 0 events as there are too many + generation f == 1 + ] + -- TODO this assumes a certain structure in the CSV file + success = case map (T.split (== ',') . T.pack) csv of + [_header, _name:s:_] | Just s <- readMaybe (T.unpack s) -> s + _ -> error $ "Cannot parse: " <> csv_fp + return $ RunLog ver frames success + +-------------------------------------------------------------------------------- + +data TraceMetric = Allocated | Copied | Live | User | Elapsed + deriving (Generic, Enum, Bounded, Read) + +instance Show TraceMetric where + show Allocated = "Allocated bytes" + show Copied = "Copied bytes" + show Live = "Live bytes" + show User = "User time" + show Elapsed = "Elapsed time" + +frameMetric :: TraceMetric -> Frame -> Double +frameMetric Allocated = fromIntegral . allocated +frameMetric Copied = fromIntegral . copied +frameMetric Live = fromIntegral . live +frameMetric Elapsed = elapsed +frameMetric User = user + +data Diagram = Diagram + { traceMetric :: TraceMetric, + runLogs :: [RunLog], + title :: String + } + deriving (Generic) + +plotDiagram :: Bool -> Diagram -> FilePath -> Action () +plotDiagram includeFailed t@Diagram {traceMetric, runLogs} out = do + let extract = frameMetric traceMetric + liftIO $ E.toFile E.def out $ do + E.layout_title E..= title t + E.setColors myColors + forM_ runLogs $ \rl -> + when (includeFailed || runSuccess rl) $ E.plot $ do + lplot <- E.line + (runVersion rl ++ if runSuccess rl then "" else " (FAILED)") + [ [ (totElapsed f, extract f) + | f <- runFrames rl + ] + ] + return (lplot E.& E.plot_lines_style . E.line_width E.*~ 2) + +-------------------------------------------------------------------------------- + +newtype Escaped a = Escaped {escaped :: a} + +newtype Unescaped a = Unescaped {unescaped :: a} + deriving newtype (Show, FromJSON, ToJSON, Eq, NFData, Binary, Hashable) + +escapeExperiment :: Unescaped String -> Escaped String +escapeExperiment = Escaped . map f . unescaped + where + f ' ' = '_' + f other = other + +unescapeExperiment :: Escaped String -> Unescaped String +unescapeExperiment = Unescaped . map f . escaped + where + f '_' = ' ' + f other = other + +-------------------------------------------------------------------------------- + +(-/-) :: FilePattern -> FilePattern -> FilePattern +a -/- b = a <> "/" <> b + +interleave :: [[a]] -> [a] +interleave = concat . transpose + +-------------------------------------------------------------------------------- + +myColors :: [E.AlphaColour Double] +myColors = map E.opaque + [ E.blue + , E.green + , E.red + , E.orange + , E.yellow + , E.violet + , E.black + , E.gold + , E.brown + , E.hotpink + , E.aliceblue + , E.aqua + , E.beige + , E.bisque + , E.blueviolet + , E.burlywood + , E.cadetblue + , E.chartreuse + , E.coral + , E.crimson + , E.darkblue + , E.darkgray + , E.darkgreen + , E.darkkhaki + , E.darkmagenta + , E.deeppink + , E.dodgerblue + , E.firebrick + , E.forestgreen + , E.fuchsia + , E.greenyellow + , E.lightsalmon + , E.seagreen + , E.olive + , E.sandybrown + , E.sienna + , E.peru + ] + +dummyHp :: String +dummyHp = + "JOB \"ghcide\" \ + \DATE \"Sun Jan 31 09:30 2021\" \ + \SAMPLE_UNIT \"seconds\" \ + \VALUE_UNIT \"bytes\" \ + \BEGIN_SAMPLE 0.000000 \ + \END_SAMPLE 0.000000" diff --git a/src/Ide/Arguments.hs b/src/Ide/Arguments.hs index 6fd6f0351..0f1f5eb8a 100644 --- a/src/Ide/Arguments.hs +++ b/src/Ide/Arguments.hs @@ -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 diff --git a/src/Ide/Version.hs b/src/Ide/Version.hs index 972c58ddc..e96376708 100644 --- a/src/Ide/Version.hs +++ b/src/Ide/Version.hs @@ -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