diff --git a/.github/workflows/flags.yml b/.github/workflows/flags.yml index 6a5089184f..1b9c46210a 100644 --- a/.github/workflows/flags.yml +++ b/.github/workflows/flags.yml @@ -69,14 +69,21 @@ jobs: ghc: ${{ matrix.ghc }} os: ${{ runner.os }} - - name: Build `hls-graph` with flags - run: cabal v2-build hls-graph --flags="embed-files stm-stats" + # 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 non-default 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 - - name: Build `ghcide` with flags - run: cabal v2-build ghcide --flags="ghc-patched-unboxed-bytecode test-exe executable bench-exe ekg" - - - name: Build with pedantic (-WError) - run: cabal v2-build --flags="pedantic" + - name: Build everything with non-default flags + run: cabal build all flags_post_job: if: always() 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/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..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 @@ -66,7 +76,6 @@ library , bytestring , containers , deepseq - , directory , exceptions , extra , filepath @@ -89,14 +98,13 @@ library build-depends: , file-embed >=0.0.11 , template-haskell + else + build-depends: + directory 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 @@ -105,6 +113,7 @@ library DataKinds test-suite tests + import: warnings type: exitcode-stdio-1.0 default-language: GHC2021 hs-source-dirs: test @@ -118,23 +127,16 @@ test-suite tests ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts - -Wunused-packages 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..e787fa024b 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 @@ -25,9 +25,10 @@ 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.Key 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 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..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 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..1d9010d53b --- /dev/null +++ b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +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) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index 39397dc19e..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 @@ -63,7 +64,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 +72,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,7 +89,7 @@ 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 + where free = fromMaybe [] $ lookupDefaultKeyMap (Just []) x mp (now,later) = foldl' g ([], insertKeyMap x Nothing mp) free g (free, mp) (k, []) = (k:free, mp) 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 af1ff57951..d780b5c921 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -1,43 +1,34 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} 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 @@ -64,7 +55,6 @@ data SRules = SRules { rulesMap :: !(IORef TheRules) } - --------------------------------------------------------------------- -- ACTIONS @@ -97,127 +87,7 @@ newtype Step = Step Int --------------------------------------------------------------------- -- Keys -data KeyValue = forall a . (Eq a, Typeable a, Hashable a, Show a) => KeyValue a Text - -newtype Key = UnsafeMkKey Int - -pattern Key a <- (lookupKeyValue -> KeyValue a _) - -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 x 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..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.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..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.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..4f15e77639 100644 --- a/hls-graph/test/DatabaseSpec.hs +++ b/hls-graph/test/DatabaseSpec.hs @@ -1,17 +1,14 @@ -{-# 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.Internal.Rules (addRule) 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 Test.Hspec @@ -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 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/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.