Fix warnings in hls-graph, enable pedantic in CI (#4047)

* Fix warnings in hls-graph, enable pedantic in CI

* Fix build with flags

* stylish-haskell

* Split Key stuff to separate module with explicit export list

* Try the cabal configure suggestion in CI flags job

* Newline fix

* Enable pedantic for all

* Typo

* stylish-haskell

* pedantic is already enabled for all

* Fix error in hls-plugin-api

* Address nitpick, use lsp-types in tests instead

Author: jhrcek

.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()

.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

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

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

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

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

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

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

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)

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,14 +64,15 @@ 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])]
 --    Where d :-> Just (k, ds), k depends on firstly d, then remaining on ds
 --    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)

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@.