From 79b4f4c24c61335d74ea0fb6b3daf849a803a111 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Sun, 4 Feb 2024 13:46:48 +0100 Subject: [PATCH 01/12] Fix warnings in hls-graph, enable pedantic in CI --- .github/workflows/flags.yml | 2 +- ghcide/src/Development/IDE/Types/Shake.hs | 4 +- hls-graph/hls-graph.cabal | 6 -- hls-graph/src/Development/IDE/Graph.hs | 2 +- .../Development/IDE/Graph/Internal/Profile.hs | 7 +- .../Development/IDE/Graph/Internal/Types.hs | 66 ++++++++++++++++++- 6 files changed, 71 insertions(+), 16 deletions(-) diff --git a/.github/workflows/flags.yml b/.github/workflows/flags.yml index 6a5089184f..5c66d1acfe 100644 --- a/.github/workflows/flags.yml +++ b/.github/workflows/flags.yml @@ -70,7 +70,7 @@ jobs: os: ${{ runner.os }} - name: Build `hls-graph` with flags - run: cabal v2-build hls-graph --flags="embed-files stm-stats" + run: cabal v2-build hls-graph --flags="embed-files stm-stats pedantic" - name: Build `ghcide` with flags run: cabal v2-build ghcide --flags="ghc-patched-unboxed-bytecode test-exe executable bench-exe ekg" diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index 9ef11582bb..36ba151762 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -24,8 +24,8 @@ import Data.Typeable (cast) import Data.Vector (Vector) import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes (FileVersion) -import Development.IDE.Graph (Key (..), RuleResult, - newKey) +import Development.IDE.Graph (Key, RuleResult, newKey, + pattern Key) import qualified Development.IDE.Graph as Shake import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index ce2a3deb34..0634753b63 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -66,7 +66,6 @@ library , bytestring , containers , deepseq - , directory , exceptions , extra , filepath @@ -122,19 +121,14 @@ test-suite tests build-depends: , base - , containers - , directory , extra - , filepath , hls-graph , hspec , stm , stm-containers , tasty , tasty-hspec - , tasty-hunit , tasty-rerun - , text , unordered-containers build-tool-depends: hspec-discover:hspec-discover diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs index 98111080a2..76bbb80d84 100644 --- a/hls-graph/src/Development/IDE/Graph.hs +++ b/hls-graph/src/Development/IDE/Graph.hs @@ -3,7 +3,7 @@ module Development.IDE.Graph( shakeOptions, Rules, Action, action, - Key(.., Key), + pattern Key, newKey, renderKey, actionFinally, actionBracket, actionCatch, actionFork, -- * Configuration diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index 39397dc19e..6a51466694 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs @@ -63,7 +63,7 @@ resultsOnly mp = mapKeyMap (\r -> -- | Given a map of representing a dependency order (with a show for error messages), find an ordering for the items such -- that no item points to an item before itself. -- Raise an error if you end up with a cycle. --- dependencyOrder :: (Eq a, Hashable a) => (a -> String) -> [(a,[a])] -> [a] +-- -- Algorithm: -- Divide everyone up into those who have no dependencies [Id] -- And those who depend on a particular Id, Dep :-> Maybe [(Key,[Dep])] @@ -71,6 +71,7 @@ resultsOnly mp = mapKeyMap (\r -> -- For each with no dependencies, add to list, then take its dep hole and -- promote them either to Nothing (if ds == []) or into a new slot. -- k :-> Nothing means the key has already been freed +dependencyOrder :: (Key -> String) -> [(Key, [Key])] -> [Key] dependencyOrder shw status = f (map fst noDeps) $ mapKeyMap Just $ @@ -87,8 +88,8 @@ dependencyOrder shw status = where (bad,badOverflow) = splitAt 10 [shw i | (i, Just _) <- toListKeyMap mp] f (x:xs) mp = x : f (now++xs) later - where Just free = lookupDefaultKeyMap (Just []) x mp - (now,later) = foldl' g ([], insertKeyMap x Nothing mp) free + where mfree = lookupDefaultKeyMap (Just []) x mp + (now,later) = foldl' g ([], insertKeyMap x Nothing mp) $ fromMaybe [] mfree g (free, mp) (k, []) = (k:free, mp) g (free, mp) (k, d:ds) = case lookupDefaultKeyMap (Just []) d mp of diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index af1ff57951..33ba4fd1c3 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -5,7 +5,65 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -module Development.IDE.Graph.Internal.Types where +module Development.IDE.Graph.Internal.Types + ( Action (..) + , Database (..) + , Step (..) + , Rules (..) + , SRules (..) + , TheRules + , RunMode (..) + , RunResult (..) + , Value (..) + , Result (..) + , ResultDeps (..) + , Status (..) + , Stack + , Key -- Opaque - don't expose constructor, use newKey to create + , pattern Key + , KeyDetails (..) + , RunChanged (..) + , SAction (..) + , StackException (..) + , ShakeDatabase (..) + , onKeyReverseDeps + , unwrapDynamic + , getDatabaseValues + , getResult + , getResultDepsDefault + , newKey + , viewDirty + , memberStack + , addStack + , mapResultDeps + , getDatabase + , emptyStack + , renderKey + -- * KeyMap + , KeyMap + , mapKeyMap + , insertKeyMap + , lookupKeyMap + , lookupDefaultKeyMap + , fromListKeyMap + , fromListWithKeyMap + , toListKeyMap + , elemsKeyMap + , restrictKeysKeyMap + -- * KeySet + , KeySet + , nullKeySet + , insertKeySet + , memberKeySet + , toListKeySet + , lengthKeySet + , filterKeySet + , singletonKeySet + , fromListKeySet + , deleteKeySet + , differenceKeySet + ) + where import Control.Monad.Catch import Control.Monad.IO.Class @@ -97,11 +155,13 @@ newtype Step = Step Int --------------------------------------------------------------------- -- Keys -data KeyValue = forall a . (Eq a, Typeable a, Hashable a, Show a) => KeyValue a Text +data KeyValue = forall a . (Typeable a, Hashable a, Show a) => KeyValue a Text newtype Key = UnsafeMkKey Int +pattern Key :: () => (Typeable a, Hashable a, Show a) => a -> Key pattern Key a <- (lookupKeyValue -> KeyValue a _) +{-# COMPLETE Key #-} data GlobalKeyValueMap = GlobalKeyValueMap !(Map.HashMap KeyValue Key) !(IntMap KeyValue) {-# UNPACK #-} !Int @@ -141,7 +201,7 @@ instance Eq KeyValue where instance Hashable KeyValue where hashWithSalt i (KeyValue x _) = hashWithSalt i (typeOf x, x) instance Show KeyValue where - show (KeyValue x t) = T.unpack t + show (KeyValue _ t) = T.unpack t renderKey :: Key -> Text renderKey (lookupKeyValue -> KeyValue _ t) = t From 5a086fec9a429bd3c6f29b310096823e9ac0290f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Sun, 4 Feb 2024 14:45:09 +0100 Subject: [PATCH 02/12] Fix build with flags --- hls-graph/hls-graph.cabal | 3 +++ hls-graph/src/Development/IDE/Graph/Internal/Profile.hs | 4 ++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 0634753b63..0a983a8e15 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -88,6 +88,9 @@ library build-depends: , file-embed >=0.0.11 , template-haskell + else + build-depends: + directory if flag(stm-stats) cpp-options: -DSTM_STATS diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index 6a51466694..a146f69a3e 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs @@ -88,8 +88,8 @@ dependencyOrder shw status = where (bad,badOverflow) = splitAt 10 [shw i | (i, Just _) <- toListKeyMap mp] f (x:xs) mp = x : f (now++xs) later - where mfree = lookupDefaultKeyMap (Just []) x mp - (now,later) = foldl' g ([], insertKeyMap x Nothing mp) $ fromMaybe [] mfree + where free = fromMaybe [] $ lookupDefaultKeyMap (Just []) x mp + (now,later) = foldl' g ([], insertKeyMap x Nothing mp) free g (free, mp) (k, []) = (k:free, mp) g (free, mp) (k, d:ds) = case lookupDefaultKeyMap (Just []) d mp of From f03a6f2a459c1d655fb64e43addf5b1200d43b37 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Sun, 4 Feb 2024 14:48:37 +0100 Subject: [PATCH 03/12] stylish-haskell --- hls-graph/src/Development/IDE/Graph.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs index 76bbb80d84..4255bf3b36 100644 --- a/hls-graph/src/Development/IDE/Graph.hs +++ b/hls-graph/src/Development/IDE/Graph.hs @@ -25,9 +25,9 @@ module Development.IDE.Graph( ) where import Development.IDE.Graph.Database -import Development.IDE.Graph.KeyMap -import Development.IDE.Graph.KeySet import Development.IDE.Graph.Internal.Action import Development.IDE.Graph.Internal.Options import Development.IDE.Graph.Internal.Rules import Development.IDE.Graph.Internal.Types +import Development.IDE.Graph.KeyMap +import Development.IDE.Graph.KeySet From c932d999888d5d384b489c7478f4070af811e8be Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Tue, 6 Feb 2024 08:29:20 +0100 Subject: [PATCH 04/12] Split Key stuff to separate module with explicit export list --- .hlint.yaml | 2 +- hls-graph/hls-graph.cabal | 17 +- hls-graph/src/Development/IDE/Graph.hs | 1 + .../src/Development/IDE/Graph/Database.hs | 1 + .../Development/IDE/Graph/Internal/Action.hs | 1 + .../IDE/Graph/Internal/Database.hs | 1 + .../src/Development/IDE/Graph/Internal/Key.hs | 174 ++++++++++++++ .../Development/IDE/Graph/Internal/Profile.hs | 1 + .../Development/IDE/Graph/Internal/Rules.hs | 1 + .../Development/IDE/Graph/Internal/Types.hs | 220 ++---------------- hls-graph/src/Development/IDE/Graph/KeyMap.hs | 2 +- hls-graph/src/Development/IDE/Graph/KeySet.hs | 2 +- hls-graph/test/ActionSpec.hs | 16 +- hls-graph/test/DatabaseSpec.hs | 19 +- hls-graph/test/Example.hs | 4 +- 15 files changed, 226 insertions(+), 236 deletions(-) create mode 100644 hls-graph/src/Development/IDE/Graph/Internal/Key.hs diff --git a/.hlint.yaml b/.hlint.yaml index 852b8060b0..e1fbcecaaf 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -60,7 +60,7 @@ - Development.IDE.Graph.Internal.Database - Development.IDE.Graph.Internal.Paths - Development.IDE.Graph.Internal.Profile - - Development.IDE.Graph.Internal.Types + - Development.IDE.Graph.Internal.Key - Ide.Types - Test.Hls - Test.Hls.Command diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 0a983a8e15..4a7e99d6ac 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -39,7 +39,16 @@ source-repository head type: git location: https://github.com/haskell/haskell-language-server +common warnings + ghc-options: + -Wall + -Wredundant-constraints + -Wunused-packages + -Wno-name-shadowing + -Wno-unticked-promoted-constructors + library + import: warnings exposed-modules: Control.Concurrent.STM.Stats Development.IDE.Graph @@ -48,6 +57,7 @@ library Development.IDE.Graph.Internal.Action Development.IDE.Graph.Internal.Database Development.IDE.Graph.Internal.Options + Development.IDE.Graph.Internal.Key Development.IDE.Graph.Internal.Paths Development.IDE.Graph.Internal.Profile Development.IDE.Graph.Internal.Rules @@ -95,10 +105,6 @@ library if flag(stm-stats) cpp-options: -DSTM_STATS - ghc-options: - -Wall -Wredundant-constraints -Wno-name-shadowing - -Wno-unticked-promoted-constructors -Wunused-packages - if flag(pedantic) ghc-options: -Werror @@ -107,6 +113,7 @@ library DataKinds test-suite tests + import: warnings type: exitcode-stdio-1.0 default-language: GHC2021 hs-source-dirs: test @@ -120,7 +127,6 @@ test-suite tests ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts - -Wunused-packages build-depends: , base @@ -132,6 +138,5 @@ test-suite tests , tasty , tasty-hspec , tasty-rerun - , unordered-containers build-tool-depends: hspec-discover:hspec-discover diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs index 4255bf3b36..e787fa024b 100644 --- a/hls-graph/src/Development/IDE/Graph.hs +++ b/hls-graph/src/Development/IDE/Graph.hs @@ -26,6 +26,7 @@ module Development.IDE.Graph( import Development.IDE.Graph.Database import Development.IDE.Graph.Internal.Action +import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Options import Development.IDE.Graph.Internal.Rules import Development.IDE.Graph.Internal.Types diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index f8f991ff1b..bd8601cd16 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -16,6 +16,7 @@ import Data.Maybe import Development.IDE.Graph.Classes () import Development.IDE.Graph.Internal.Action import Development.IDE.Graph.Internal.Database +import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Options import Development.IDE.Graph.Internal.Profile (writeProfile) import Development.IDE.Graph.Internal.Rules diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 7a7430dd9e..14d8f38b2c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -27,6 +27,7 @@ import Data.Functor.Identity import Data.IORef import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Database +import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Rules (RuleResult) import Development.IDE.Graph.Internal.Types import System.Exit diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 6a053ff51f..e9830a5d35 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -40,6 +40,7 @@ import qualified ListT import qualified StmContainers.Map as SMap import System.IO.Unsafe import System.Time.Extra (duration, sleep) +import Development.IDE.Graph.Internal.Key newDatabase :: Dynamic -> TheRules -> IO Database diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs new file mode 100644 index 0000000000..c3e8fe145a --- /dev/null +++ b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DerivingStrategies #-} + +module Development.IDE.Graph.Internal.Key + ( Key -- Opaque - don't expose constructor, use newKey to create + , KeyValue (..) + , pattern Key + , newKey + , renderKey + -- * KeyMap + , KeyMap + , mapKeyMap + , insertKeyMap + , lookupKeyMap + , lookupDefaultKeyMap + , fromListKeyMap + , fromListWithKeyMap + , toListKeyMap + , elemsKeyMap + , restrictKeysKeyMap + -- * KeySet + , KeySet + , nullKeySet + , insertKeySet + , memberKeySet + , toListKeySet + , lengthKeySet + , filterKeySet + , singletonKeySet + , fromListKeySet + , deleteKeySet + , differenceKeySet + ) where + +--import Control.Monad.IO.Class () +import Data.Coerce +import Data.Dynamic +import qualified Data.HashMap.Strict as Map +import Data.IntMap (IntMap) +import qualified Data.IntMap.Strict as IM +import Data.IntSet (IntSet) +import qualified Data.IntSet as IS +import Data.IORef +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable +import Development.IDE.Graph.Classes +import System.IO.Unsafe + + +newtype Key = UnsafeMkKey Int + +pattern Key :: () => (Typeable a, Hashable a, Show a) => a -> Key +pattern Key a <- (lookupKeyValue -> KeyValue a _) +{-# COMPLETE Key #-} + +data KeyValue = forall a . (Typeable a, Hashable a, Show a) => KeyValue a Text + +instance Eq KeyValue where + KeyValue a _ == KeyValue b _ = Just a == cast b +instance Hashable KeyValue where + hashWithSalt i (KeyValue x _) = hashWithSalt i (typeOf x, x) +instance Show KeyValue where + show (KeyValue _ t) = T.unpack t + +data GlobalKeyValueMap = GlobalKeyValueMap !(Map.HashMap KeyValue Key) !(IntMap KeyValue) {-# UNPACK #-} !Int + +keyMap :: IORef GlobalKeyValueMap +keyMap = unsafePerformIO $ newIORef (GlobalKeyValueMap Map.empty IM.empty 0) + +{-# NOINLINE keyMap #-} + +newKey :: (Typeable a, Hashable a, Show a) => a -> Key +newKey k = unsafePerformIO $ do + let !newKey = KeyValue k (T.pack (show k)) + atomicModifyIORef' keyMap $ \km@(GlobalKeyValueMap hm im n) -> + let new_key = Map.lookup newKey hm + in case new_key of + Just v -> (km, v) + Nothing -> + let !new_index = UnsafeMkKey n + in (GlobalKeyValueMap (Map.insert newKey new_index hm) (IM.insert n newKey im) (n+1), new_index) +{-# NOINLINE newKey #-} + +lookupKeyValue :: Key -> KeyValue +lookupKeyValue (UnsafeMkKey x) = unsafePerformIO $ do + GlobalKeyValueMap _ im _ <- readIORef keyMap + pure $! im IM.! x + +{-# NOINLINE lookupKeyValue #-} + +instance Eq Key where + UnsafeMkKey a == UnsafeMkKey b = a == b +instance Hashable Key where + hashWithSalt i (UnsafeMkKey x) = hashWithSalt i x +instance Show Key where + show (Key x) = show x + +renderKey :: Key -> Text +renderKey (lookupKeyValue -> KeyValue _ t) = t + +newtype KeySet = KeySet IntSet + deriving newtype (Eq, Ord, Semigroup, Monoid) + +instance Show KeySet where + showsPrec p (KeySet is)= showParen (p > 10) $ + showString "fromList " . shows ks + where ks = coerce (IS.toList is) :: [Key] + +insertKeySet :: Key -> KeySet -> KeySet +insertKeySet = coerce IS.insert + +memberKeySet :: Key -> KeySet -> Bool +memberKeySet = coerce IS.member + +toListKeySet :: KeySet -> [Key] +toListKeySet = coerce IS.toList + +nullKeySet :: KeySet -> Bool +nullKeySet = coerce IS.null + +differenceKeySet :: KeySet -> KeySet -> KeySet +differenceKeySet = coerce IS.difference + +deleteKeySet :: Key -> KeySet -> KeySet +deleteKeySet = coerce IS.delete + +fromListKeySet :: [Key] -> KeySet +fromListKeySet = coerce IS.fromList + +singletonKeySet :: Key -> KeySet +singletonKeySet = coerce IS.singleton + +filterKeySet :: (Key -> Bool) -> KeySet -> KeySet +filterKeySet = coerce IS.filter + +lengthKeySet :: KeySet -> Int +lengthKeySet = coerce IS.size + +newtype KeyMap a = KeyMap (IntMap a) + deriving newtype (Eq, Ord, Semigroup, Monoid) + +instance Show a => Show (KeyMap a) where + showsPrec p (KeyMap im)= showParen (p > 10) $ + showString "fromList " . shows ks + where ks = coerce (IM.toList im) :: [(Key,a)] + +mapKeyMap :: (a -> b) -> KeyMap a -> KeyMap b +mapKeyMap f (KeyMap m) = KeyMap (IM.map f m) + +insertKeyMap :: Key -> a -> KeyMap a -> KeyMap a +insertKeyMap (UnsafeMkKey k) v (KeyMap m) = KeyMap (IM.insert k v m) + +lookupKeyMap :: Key -> KeyMap a -> Maybe a +lookupKeyMap (UnsafeMkKey k) (KeyMap m) = IM.lookup k m + +lookupDefaultKeyMap :: a -> Key -> KeyMap a -> a +lookupDefaultKeyMap a (UnsafeMkKey k) (KeyMap m) = IM.findWithDefault a k m + +fromListKeyMap :: [(Key,a)] -> KeyMap a +fromListKeyMap xs = KeyMap (IM.fromList (coerce xs)) + +fromListWithKeyMap :: (a -> a -> a) -> [(Key,a)] -> KeyMap a +fromListWithKeyMap f xs = KeyMap (IM.fromListWith f (coerce xs)) + +toListKeyMap :: KeyMap a -> [(Key,a)] +toListKeyMap (KeyMap m) = coerce (IM.toList m) + +elemsKeyMap :: KeyMap a -> [a] +elemsKeyMap (KeyMap m) = IM.elems m + +restrictKeysKeyMap :: KeyMap a -> KeySet -> KeyMap a +restrictKeysKeyMap (KeyMap m) (KeySet s) = KeyMap (IM.restrictKeys m s) \ No newline at end of file diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index a146f69a3e..408e3d2f12 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs @@ -22,6 +22,7 @@ import Data.Maybe import Data.Time (getCurrentTime) import Data.Time.Format.ISO8601 (iso8601Show) import Development.IDE.Graph.Internal.Database (getDirtySet) +import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Paths import Development.IDE.Graph.Internal.Types import qualified Language.Javascript.DGTable as DGTable diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs index b68805b4ee..9a5f36ca35 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs @@ -17,6 +17,7 @@ import Data.IORef import Data.Maybe import Data.Typeable import Development.IDE.Graph.Classes +import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Types -- | The type mapping between the @key@ or a rule and the resulting @value@. diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 33ba4fd1c3..d780b5c921 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -1,101 +1,34 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} - -module Development.IDE.Graph.Internal.Types - ( Action (..) - , Database (..) - , Step (..) - , Rules (..) - , SRules (..) - , TheRules - , RunMode (..) - , RunResult (..) - , Value (..) - , Result (..) - , ResultDeps (..) - , Status (..) - , Stack - , Key -- Opaque - don't expose constructor, use newKey to create - , pattern Key - , KeyDetails (..) - , RunChanged (..) - , SAction (..) - , StackException (..) - , ShakeDatabase (..) - , onKeyReverseDeps - , unwrapDynamic - , getDatabaseValues - , getResult - , getResultDepsDefault - , newKey - , viewDirty - , memberStack - , addStack - , mapResultDeps - , getDatabase - , emptyStack - , renderKey - -- * KeyMap - , KeyMap - , mapKeyMap - , insertKeyMap - , lookupKeyMap - , lookupDefaultKeyMap - , fromListKeyMap - , fromListWithKeyMap - , toListKeyMap - , elemsKeyMap - , restrictKeysKeyMap - -- * KeySet - , KeySet - , nullKeySet - , insertKeySet - , memberKeySet - , toListKeySet - , lengthKeySet - , filterKeySet - , singletonKeySet - , fromListKeySet - , deleteKeySet - , differenceKeySet - ) - where + +module Development.IDE.Graph.Internal.Types where import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Reader -import Data.Aeson (FromJSON, ToJSON) -import Data.Bifunctor (second) -import qualified Data.ByteString as BS -import Data.Coerce +import Data.Aeson (FromJSON, ToJSON) +import Data.Bifunctor (second) +import qualified Data.ByteString as BS import Data.Dynamic -import qualified Data.HashMap.Strict as Map -import Data.IntMap (IntMap) -import qualified Data.IntMap.Strict as IM -import Data.IntSet (IntSet) -import qualified Data.IntSet as IS +import qualified Data.HashMap.Strict as Map import Data.IORef -import Data.List (intercalate) +import Data.List (intercalate) import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T import Data.Typeable import Development.IDE.Graph.Classes -import GHC.Conc (TVar, atomically) -import GHC.Generics (Generic) +import Development.IDE.Graph.Internal.Key +import GHC.Conc (TVar, atomically) +import GHC.Generics (Generic) import qualified ListT -import qualified StmContainers.Map as SMap -import StmContainers.Map (Map) -import System.IO.Unsafe -import System.Time.Extra (Seconds) -import UnliftIO (MonadUnliftIO) +import qualified StmContainers.Map as SMap +import StmContainers.Map (Map) +import System.Time.Extra (Seconds) +import UnliftIO (MonadUnliftIO) #if !MIN_VERSION_base(4,18,0) -import Control.Applicative (liftA2) +import Control.Applicative (liftA2) #endif unwrapDynamic :: forall a . Typeable a => Dynamic -> a @@ -122,7 +55,6 @@ data SRules = SRules { rulesMap :: !(IORef TheRules) } - --------------------------------------------------------------------- -- ACTIONS @@ -155,129 +87,7 @@ newtype Step = Step Int --------------------------------------------------------------------- -- Keys -data KeyValue = forall a . (Typeable a, Hashable a, Show a) => KeyValue a Text - -newtype Key = UnsafeMkKey Int - -pattern Key :: () => (Typeable a, Hashable a, Show a) => a -> Key -pattern Key a <- (lookupKeyValue -> KeyValue a _) -{-# COMPLETE Key #-} - -data GlobalKeyValueMap = GlobalKeyValueMap !(Map.HashMap KeyValue Key) !(IntMap KeyValue) {-# UNPACK #-} !Int - -keyMap :: IORef GlobalKeyValueMap -keyMap = unsafePerformIO $ newIORef (GlobalKeyValueMap Map.empty IM.empty 0) - -{-# NOINLINE keyMap #-} - -newKey :: (Typeable a, Hashable a, Show a) => a -> Key -newKey k = unsafePerformIO $ do - let !newKey = KeyValue k (T.pack (show k)) - atomicModifyIORef' keyMap $ \km@(GlobalKeyValueMap hm im n) -> - let new_key = Map.lookup newKey hm - in case new_key of - Just v -> (km, v) - Nothing -> - let !new_index = UnsafeMkKey n - in (GlobalKeyValueMap (Map.insert newKey new_index hm) (IM.insert n newKey im) (n+1), new_index) -{-# NOINLINE newKey #-} - -lookupKeyValue :: Key -> KeyValue -lookupKeyValue (UnsafeMkKey x) = unsafePerformIO $ do - GlobalKeyValueMap _ im _ <- readIORef keyMap - pure $! im IM.! x - -{-# NOINLINE lookupKeyValue #-} - -instance Eq Key where - UnsafeMkKey a == UnsafeMkKey b = a == b -instance Hashable Key where - hashWithSalt i (UnsafeMkKey x) = hashWithSalt i x -instance Show Key where - show (Key x) = show x - -instance Eq KeyValue where - KeyValue a _ == KeyValue b _ = Just a == cast b -instance Hashable KeyValue where - hashWithSalt i (KeyValue x _) = hashWithSalt i (typeOf x, x) -instance Show KeyValue where - show (KeyValue _ t) = T.unpack t - -renderKey :: Key -> Text -renderKey (lookupKeyValue -> KeyValue _ t) = t - -newtype KeySet = KeySet IntSet - deriving newtype (Eq, Ord, Semigroup, Monoid) - -instance Show KeySet where - showsPrec p (KeySet is)= showParen (p > 10) $ - showString "fromList " . shows ks - where ks = coerce (IS.toList is) :: [Key] - -insertKeySet :: Key -> KeySet -> KeySet -insertKeySet = coerce IS.insert - -memberKeySet :: Key -> KeySet -> Bool -memberKeySet = coerce IS.member - -toListKeySet :: KeySet -> [Key] -toListKeySet = coerce IS.toList - -nullKeySet :: KeySet -> Bool -nullKeySet = coerce IS.null - -differenceKeySet :: KeySet -> KeySet -> KeySet -differenceKeySet = coerce IS.difference - -deleteKeySet :: Key -> KeySet -> KeySet -deleteKeySet = coerce IS.delete - -fromListKeySet :: [Key] -> KeySet -fromListKeySet = coerce IS.fromList - -singletonKeySet :: Key -> KeySet -singletonKeySet = coerce IS.singleton - -filterKeySet :: (Key -> Bool) -> KeySet -> KeySet -filterKeySet = coerce IS.filter - -lengthKeySet :: KeySet -> Int -lengthKeySet = coerce IS.size - -newtype KeyMap a = KeyMap (IntMap a) - deriving newtype (Eq, Ord, Semigroup, Monoid) - -instance Show a => Show (KeyMap a) where - showsPrec p (KeyMap im)= showParen (p > 10) $ - showString "fromList " . shows ks - where ks = coerce (IM.toList im) :: [(Key,a)] - -mapKeyMap :: (a -> b) -> KeyMap a -> KeyMap b -mapKeyMap f (KeyMap m) = KeyMap (IM.map f m) - -insertKeyMap :: Key -> a -> KeyMap a -> KeyMap a -insertKeyMap (UnsafeMkKey k) v (KeyMap m) = KeyMap (IM.insert k v m) - -lookupKeyMap :: Key -> KeyMap a -> Maybe a -lookupKeyMap (UnsafeMkKey k) (KeyMap m) = IM.lookup k m - -lookupDefaultKeyMap :: a -> Key -> KeyMap a -> a -lookupDefaultKeyMap a (UnsafeMkKey k) (KeyMap m) = IM.findWithDefault a k m - -fromListKeyMap :: [(Key,a)] -> KeyMap a -fromListKeyMap xs = KeyMap (IM.fromList (coerce xs)) - -fromListWithKeyMap :: (a -> a -> a) -> [(Key,a)] -> KeyMap a -fromListWithKeyMap f xs = KeyMap (IM.fromListWith f (coerce xs)) - -toListKeyMap :: KeyMap a -> [(Key,a)] -toListKeyMap (KeyMap m) = coerce (IM.toList m) - -elemsKeyMap :: KeyMap a -> [a] -elemsKeyMap (KeyMap m) = IM.elems m -restrictKeysKeyMap :: KeyMap a -> KeySet -> KeyMap a -restrictKeysKeyMap (KeyMap m) (KeySet s) = KeyMap (IM.restrictKeys m s) newtype Value = Value Dynamic diff --git a/hls-graph/src/Development/IDE/Graph/KeyMap.hs b/hls-graph/src/Development/IDE/Graph/KeyMap.hs index daa1ae8642..87a95733e5 100644 --- a/hls-graph/src/Development/IDE/Graph/KeyMap.hs +++ b/hls-graph/src/Development/IDE/Graph/KeyMap.hs @@ -12,4 +12,4 @@ module Development.IDE.Graph.KeyMap( restrictKeysKeyMap, ) where -import Development.IDE.Graph.Internal.Types +import Development.IDE.Graph.Internal.Key diff --git a/hls-graph/src/Development/IDE/Graph/KeySet.hs b/hls-graph/src/Development/IDE/Graph/KeySet.hs index ef8c46e6b5..4f52cfb405 100644 --- a/hls-graph/src/Development/IDE/Graph/KeySet.hs +++ b/hls-graph/src/Development/IDE/Graph/KeySet.hs @@ -13,4 +13,4 @@ module Development.IDE.Graph.KeySet( lengthKeySet, ) where -import Development.IDE.Graph.Internal.Types +import Development.IDE.Graph.Internal.Key diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 2148e38d2e..cfa7a5eeef 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -4,16 +4,14 @@ module ActionSpec where import Control.Concurrent.STM -import qualified Data.HashSet as HashSet -import Development.IDE.Graph (shakeOptions) -import Development.IDE.Graph.Database (shakeNewDatabase, - shakeRunDatabase) -import Development.IDE.Graph.Internal.Action (apply1) +import Development.IDE.Graph (shakeOptions) +import Development.IDE.Graph.Database (shakeNewDatabase, + shakeRunDatabase) +import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Types import Development.IDE.Graph.Rule import Example -import qualified StmContainers.Map as STM -import System.Time.Extra (timeout) +import qualified StmContainers.Map as STM import Test.Hspec spec :: Spec @@ -56,14 +54,14 @@ spec = do keyReverseDeps `shouldBe` (singletonKeySet $ newKey theKey) it "rethrows exceptions" $ do db <- shakeNewDatabase shakeOptions $ do - addRule $ \(Rule :: Rule ()) old mode -> error "boom" + addRule $ \(Rule :: Rule ()) _old _mode -> error "boom" let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) res `shouldThrow` anyErrorCall describe "applyWithoutDependency" $ do it "does not track dependencies" $ do db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do ruleUnit - addRule $ \Rule old mode -> do + addRule $ \Rule _old _mode -> do [()] <- applyWithoutDependency [Rule] return $ RunResult ChangedRecomputeDiff "" True diff --git a/hls-graph/test/DatabaseSpec.hs b/hls-graph/test/DatabaseSpec.hs index 38d494ee0c..f1651eb592 100644 --- a/hls-graph/test/DatabaseSpec.hs +++ b/hls-graph/test/DatabaseSpec.hs @@ -1,18 +1,15 @@ -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} + module DatabaseSpec where -import Control.Concurrent.STM -import Development.IDE.Graph (shakeOptions) -import Development.IDE.Graph.Database (shakeNewDatabase, - shakeRunDatabase) -import Development.IDE.Graph.Internal.Action (apply1) +import Development.IDE.Graph (shakeOptions) +import Development.IDE.Graph.Database (shakeNewDatabase, + shakeRunDatabase) import Development.IDE.Graph.Internal.Types -import Development.IDE.Graph.Rule +import Development.IDE.Graph.Internal.Action ( apply1 ) +import Development.IDE.Graph.Internal.Rules ( addRule ) import Example -import qualified StmContainers.Map as STM -import System.Time.Extra (timeout) +import System.Time.Extra (timeout) import Test.Hspec spec :: Spec @@ -21,7 +18,7 @@ spec = do it "detects cycles" $ do db <- shakeNewDatabase shakeOptions $ do ruleBool - addRule $ \Rule old mode -> do + addRule $ \Rule _old _mode -> do True <- apply1 (Rule @Bool) return $ RunResult ChangedRecomputeDiff "" () let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) diff --git a/hls-graph/test/Example.hs b/hls-graph/test/Example.hs index 2bb2dc9267..1a897fc174 100644 --- a/hls-graph/test/Example.hs +++ b/hls-graph/test/Example.hs @@ -19,11 +19,11 @@ instance Typeable a => Show (Rule a) where type instance RuleResult (Rule a) = a ruleUnit :: Rules () -ruleUnit = addRule $ \(Rule :: Rule ()) old mode -> do +ruleUnit = addRule $ \(Rule :: Rule ()) _old _mode -> do return $ RunResult ChangedRecomputeDiff "" () -- | Depends on Rule @() ruleBool :: Rules () -ruleBool = addRule $ \Rule old mode -> do +ruleBool = addRule $ \Rule _old _mode -> do () <- apply1 Rule return $ RunResult ChangedRecomputeDiff "" True From 756b537cd810dfb7e83b16cfc8a6412cacc5825b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Tue, 6 Feb 2024 08:47:20 +0100 Subject: [PATCH 05/12] Try the cabal configure suggestion in CI flags job --- .github/workflows/flags.yml | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/.github/workflows/flags.yml b/.github/workflows/flags.yml index 5c66d1acfe..1236f05ef3 100644 --- a/.github/workflows/flags.yml +++ b/.github/workflows/flags.yml @@ -69,14 +69,15 @@ jobs: ghc: ${{ matrix.ghc }} os: ${{ runner.os }} - - name: Build `hls-graph` with flags - run: cabal v2-build hls-graph --flags="embed-files stm-stats pedantic" - - - name: Build `ghcide` with flags - run: cabal v2-build ghcide --flags="ghc-patched-unboxed-bytecode test-exe executable bench-exe ekg" + - name: Configue extra flags for some components + run: | + cabal configure \ + --constraint "hls-graph +embed-files +stm-stats +pedantic" \ + --constraint "ghcide +ekg +executable +pedantic +test-exe" + cat cabal.project.local - name: Build with pedantic (-WError) - run: cabal v2-build --flags="pedantic" + run: cabal v2-build --flags=pedantic flags_post_job: if: always() From c5e232424ddf4f98e6dece997cf413fc07689ff3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Tue, 6 Feb 2024 08:51:11 +0100 Subject: [PATCH 06/12] Newline fix --- hls-graph/src/Development/IDE/Graph/Internal/Key.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs index c3e8fe145a..fced34f360 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs @@ -171,4 +171,4 @@ elemsKeyMap :: KeyMap a -> [a] elemsKeyMap (KeyMap m) = IM.elems m restrictKeysKeyMap :: KeyMap a -> KeySet -> KeyMap a -restrictKeysKeyMap (KeyMap m) (KeySet s) = KeyMap (IM.restrictKeys m s) \ No newline at end of file +restrictKeysKeyMap (KeyMap m) (KeySet s) = KeyMap (IM.restrictKeys m s) From f926008bf8d26c8cbe6d2f66c93cac8fcf2c6d77 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Tue, 6 Feb 2024 08:56:46 +0100 Subject: [PATCH 07/12] Enable pedantic for all --- .github/workflows/flags.yml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/.github/workflows/flags.yml b/.github/workflows/flags.yml index 1236f05ef3..487f22d4db 100644 --- a/.github/workflows/flags.yml +++ b/.github/workflows/flags.yml @@ -69,15 +69,16 @@ jobs: ghc: ${{ matrix.ghc }} os: ${{ runner.os }} - - name: Configue extra flags for some components + - name: Configue flags for all components run: | cabal configure \ - --constraint "hls-graph +embed-files +stm-stats +pedantic" \ - --constraint "ghcide +ekg +executable +pedantic +test-exe" + --constraint "hls-graph +embed-files +stm-stats +pedantic" \ + --constraint "ghcide +ekg +executable +pedantic +test-exe" \ + --constraint "all +pedantic" cat cabal.project.local - name: Build with pedantic (-WError) - run: cabal v2-build --flags=pedantic + run: cabal buid all flags_post_job: if: always() From fca6e476dce442544d5197fb32c451d6268b09a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Tue, 6 Feb 2024 08:59:36 +0100 Subject: [PATCH 08/12] Typo --- .github/workflows/flags.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/flags.yml b/.github/workflows/flags.yml index 487f22d4db..d1c3a0a827 100644 --- a/.github/workflows/flags.yml +++ b/.github/workflows/flags.yml @@ -78,7 +78,7 @@ jobs: cat cabal.project.local - name: Build with pedantic (-WError) - run: cabal buid all + run: cabal build all flags_post_job: if: always() From 66f831de9c875625ef09fa062335a21c1d87eb85 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Tue, 6 Feb 2024 09:05:19 +0100 Subject: [PATCH 09/12] stylish-haskell --- .../src/Development/IDE/Graph/Internal/Database.hs | 2 +- hls-graph/src/Development/IDE/Graph/Internal/Key.hs | 2 +- hls-graph/src/Development/IDE/Graph/KeyMap.hs | 2 +- hls-graph/src/Development/IDE/Graph/KeySet.hs | 2 +- hls-graph/test/DatabaseSpec.hs | 12 ++++++------ 5 files changed, 10 insertions(+), 10 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index e9830a5d35..d8fc096639 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -33,6 +33,7 @@ import Data.Traversable (for) import Data.Tuple.Extra import Debug.Trace (traceM) import Development.IDE.Graph.Classes +import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Rules import Development.IDE.Graph.Internal.Types import qualified Focus @@ -40,7 +41,6 @@ import qualified ListT import qualified StmContainers.Map as SMap import System.IO.Unsafe import System.Time.Extra (duration, sleep) -import Development.IDE.Graph.Internal.Key newDatabase :: Dynamic -> TheRules -> IO Database diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs index fced34f360..1d9010d53b 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DerivingStrategies #-} module Development.IDE.Graph.Internal.Key ( Key -- Opaque - don't expose constructor, use newKey to create diff --git a/hls-graph/src/Development/IDE/Graph/KeyMap.hs b/hls-graph/src/Development/IDE/Graph/KeyMap.hs index 87a95733e5..30ff4d6cfa 100644 --- a/hls-graph/src/Development/IDE/Graph/KeyMap.hs +++ b/hls-graph/src/Development/IDE/Graph/KeyMap.hs @@ -12,4 +12,4 @@ module Development.IDE.Graph.KeyMap( restrictKeysKeyMap, ) where -import Development.IDE.Graph.Internal.Key +import Development.IDE.Graph.Internal.Key diff --git a/hls-graph/src/Development/IDE/Graph/KeySet.hs b/hls-graph/src/Development/IDE/Graph/KeySet.hs index 4f52cfb405..cd0e76e675 100644 --- a/hls-graph/src/Development/IDE/Graph/KeySet.hs +++ b/hls-graph/src/Development/IDE/Graph/KeySet.hs @@ -13,4 +13,4 @@ module Development.IDE.Graph.KeySet( lengthKeySet, ) where -import Development.IDE.Graph.Internal.Key +import Development.IDE.Graph.Internal.Key diff --git a/hls-graph/test/DatabaseSpec.hs b/hls-graph/test/DatabaseSpec.hs index f1651eb592..4f15e77639 100644 --- a/hls-graph/test/DatabaseSpec.hs +++ b/hls-graph/test/DatabaseSpec.hs @@ -2,14 +2,14 @@ module DatabaseSpec where -import Development.IDE.Graph (shakeOptions) -import Development.IDE.Graph.Database (shakeNewDatabase, - shakeRunDatabase) +import Development.IDE.Graph (shakeOptions) +import Development.IDE.Graph.Database (shakeNewDatabase, + shakeRunDatabase) +import Development.IDE.Graph.Internal.Action (apply1) +import Development.IDE.Graph.Internal.Rules (addRule) import Development.IDE.Graph.Internal.Types -import Development.IDE.Graph.Internal.Action ( apply1 ) -import Development.IDE.Graph.Internal.Rules ( addRule ) import Example -import System.Time.Extra (timeout) +import System.Time.Extra (timeout) import Test.Hspec spec :: Spec From a275fa1f0c15bea9f7bdf3c64aa77533cfdaf5f1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Tue, 6 Feb 2024 09:09:27 +0100 Subject: [PATCH 10/12] pedantic is already enabled for all --- .github/workflows/flags.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/flags.yml b/.github/workflows/flags.yml index d1c3a0a827..a3064367f0 100644 --- a/.github/workflows/flags.yml +++ b/.github/workflows/flags.yml @@ -72,8 +72,8 @@ jobs: - name: Configue flags for all components run: | cabal configure \ - --constraint "hls-graph +embed-files +stm-stats +pedantic" \ - --constraint "ghcide +ekg +executable +pedantic +test-exe" \ + --constraint "hls-graph +embed-files +stm-stats" \ + --constraint "ghcide +ekg +executable +test-exe" \ --constraint "all +pedantic" cat cabal.project.local From 36cb7d1edffad60b62f01833752525e4e347ae9a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Tue, 6 Feb 2024 10:09:27 +0100 Subject: [PATCH 11/12] Fix error in hls-plugin-api --- .github/workflows/flags.yml | 5 +++++ hls-plugin-api/bench/Main.hs | 18 +++++++++--------- hls-plugin-api/hls-plugin-api.cabal | 2 +- hls-plugin-api/src/Ide/Plugin/RangeMap.hs | 4 +++- 4 files changed, 18 insertions(+), 11 deletions(-) diff --git a/.github/workflows/flags.yml b/.github/workflows/flags.yml index a3064367f0..f3eb5ef265 100644 --- a/.github/workflows/flags.yml +++ b/.github/workflows/flags.yml @@ -69,11 +69,16 @@ jobs: ghc: ${{ matrix.ghc }} os: ${{ runner.os }} + # The purpose of this job is to ensure that the build works even with flags + # in their non-default settings. Below we: + # - enable flags that are off by default + # - disable flags that are on by default - name: Configue flags for all components run: | cabal configure \ --constraint "hls-graph +embed-files +stm-stats" \ --constraint "ghcide +ekg +executable +test-exe" \ + --constraint "hls-plugin-api -use-fingertree" \ --constraint "all +pedantic" cat cabal.project.local diff --git a/hls-plugin-api/bench/Main.hs b/hls-plugin-api/bench/Main.hs index 0fc64f49f1..52006af16d 100644 --- a/hls-plugin-api/bench/Main.hs +++ b/hls-plugin-api/bench/Main.hs @@ -2,17 +2,17 @@ -- vs RangeMap-based "in-range filtering" approaches module Main (main) where -import Control.DeepSeq (force) -import Control.Exception (evaluate) -import Control.Monad (replicateM) +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Control.Monad (replicateM) import qualified Criterion import qualified Criterion.Main -import Data.Random (RVar) -import qualified Data.Random as Fu -import qualified Ide.Plugin.RangeMap as RangeMap -import Language.LSP.Types (Position (..), Range (..), UInt, - isSubrangeOf) -import qualified System.Random.Stateful as Random +import Data.Random (RVar) +import qualified Data.Random as Fu +import qualified Ide.Plugin.RangeMap as RangeMap +import Language.LSP.Protocol.Types (Position (..), Range (..), UInt, + isSubrangeOf) +import qualified System.Random.Stateful as Random genRangeList :: Int -> RVar [Range] diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 76ce242581..baa4bb182c 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -142,6 +142,6 @@ benchmark rangemap-benchmark , criterion , deepseq , hls-plugin-api - , lsp-types + , lsp-test , random , random-fu diff --git a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs index 465a2f31d2..8ec62e68e6 100644 --- a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs +++ b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs @@ -14,14 +14,16 @@ module Ide.Plugin.RangeMap fromList', filterByRange, ) where + import Development.IDE.Graph.Classes (NFData) -import Language.LSP.Protocol.Types (Range, isSubrangeOf) #ifdef USE_FINGERTREE import Data.Bifunctor (first) import Data.Foldable (foldl') import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM import Language.LSP.Protocol.Types (Position, Range (Range)) +#else +import Language.LSP.Protocol.Types (Range, isSubrangeOf) #endif -- | A map from code ranges to values. From bf612f23605d4db671da45ea47c2dfa4f805d59f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Tue, 6 Feb 2024 13:21:13 +0100 Subject: [PATCH 12/12] Address nitpick, use lsp-types in tests instead --- .github/workflows/flags.yml | 4 ++-- hls-plugin-api/hls-plugin-api.cabal | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/flags.yml b/.github/workflows/flags.yml index f3eb5ef265..1b9c46210a 100644 --- a/.github/workflows/flags.yml +++ b/.github/workflows/flags.yml @@ -73,7 +73,7 @@ jobs: # in their non-default settings. Below we: # - enable flags that are off by default # - disable flags that are on by default - - name: Configue flags for all components + - name: Configue non-default flags for all components run: | cabal configure \ --constraint "hls-graph +embed-files +stm-stats" \ @@ -82,7 +82,7 @@ jobs: --constraint "all +pedantic" cat cabal.project.local - - name: Build with pedantic (-WError) + - name: Build everything with non-default flags run: cabal build all flags_post_job: diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index baa4bb182c..76ce242581 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -142,6 +142,6 @@ benchmark rangemap-benchmark , criterion , deepseq , hls-plugin-api - , lsp-test + , lsp-types , random , random-fu