Support per-project hlint customization (.dlint.yaml files) (digital-…

…asset#2328) * Support per-project hlint customization (.dlint.yaml files) * Simplify logic with 'foldMapM'
FlashSheridan · Jul 30, 2019 · 18ecf0e · 18ecf0e
1 parent 29fa387
commit 18ecf0e
Showing 1 changed file with 20 additions and 8 deletions.
diff --git a/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs b/compiler/damlc/daml-ide-core/src/Development/IDE/Core/Rules/Daml.hs
@@ -20,6 +20,7 @@ import Data.Aeson hiding (Options)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.UTF8 as BS
 import Data.Either.Extra
+import Data.Foldable
 import Data.List
 import qualified Data.Map.Strict as Map
 import Data.Maybe
@@ -32,6 +33,7 @@ import Development.Shake hiding (Diagnostic, Env)
 import "ghc-lib" GHC
 import "ghc-lib-parser" Module (stringToUnitId, UnitId(..), DefUnitId(..))
 import Safe
+import System.IO.Error
 import System.Directory.Extra
 import System.FilePath
 
@@ -572,14 +574,24 @@ encodeModuleRule =
 
 hlintSettings :: FilePath -> IO ([Classify], Hint)
 hlintSettings hlintDataDir = do
-  -- `findSettings` ends up calling `readFilesConfig` which in turn
-  -- calls `readFileConfigYaml` which finally calls `decodeFileEither`
-  -- from the `yaml` library.  Annoyingly that function catches async
-  -- exceptions and in particular, it ends up catching `ThreadKilled`.
-  -- So, we have to mask to stop it from doing that.
-  (_, classify, hints) <- mask $ \unmask ->
-    findSettings (unmask . readSettingsFile (Just hlintDataDir)) Nothing
-  return (classify, hints)
+    curdir <- getCurrentDirectory
+    home <- ((:[]) <$> getHomeDirectory) `catchIOError` (const $ return [])
+    dlintYaml <-
+      findM System.Directory.Extra.doesFileExist $
+        map (</> ".dlint.yaml") (ancestors curdir ++ home)
+    (_, cs, hs) <- foldMapM parseSettings $
+      (hlintDataDir </> "hlint.yaml") : maybeToList dlintYaml
+    return (cs, hs)
+    where
+      ancestors = init . map joinPath . reverse . inits . splitPath
+      -- `findSettings` calls `readFilesConfig` which in turn calls
+      -- `readFileConfigYaml` which finally calls `decodeFileEither` from
+      -- the `yaml` library.  Annoyingly that function catches async
+      -- exceptions and in particular, it ends up catching
+      -- `ThreadKilled`. So, we have to mask to stop it from doing that.
+      parseSettings f = mask $ \unmask ->
+           findSettings (unmask . const (return (f, Nothing))) (Just f)
+      foldMapM f = foldlM (\acc a -> do w <- f a; return $! mappend acc w) mempty
 
 getHlintSettingsRule :: HlintUsage -> Rules ()
 getHlintSettingsRule usage =