Allow specifying a stack.yaml for stack configurations

.gitignore

@@ -1,7 +1,7 @@
 dist/
 dist-newstyle/
 .stack-work/
-stack.yaml
-stack.yaml.lock
+tests/projects/**/stack*.yaml
+tests/projects/**/stack*.yaml.lock
 cabal.project.local*
 .vscode/

README.md

@@ -73,6 +73,16 @@ cradle:
 
 This configuration suffices if your whole project can be loaded by the command `stack repl`. As a rule of thumb, this works if the project consists of only one executable, one library and one test-suite.
 
+Some projects have multiple `stack-*.yaml` files for multiple versions of ghc/resolvers. In this case you
+can specify an alternate relative file to use by using the `stackYaml` option. The path is relative to the
+configuration file.
+
+```yaml
+cradle:
+  stack:
+    stackYaml: "./stack-8.8.3.yaml"
+```
+
 If your project is more complicated, you need to specify which [components](https://docs.haskellstack.org/en/stable/build_command/#components) you want to load. A component is, roughly speaking, a library/executable/test-suite or benchmark in `stack`. You can view the components/targets of a stack project by executing the command:
 ``` sh
 $ stack ide targets
@@ -126,6 +136,26 @@ Here you can see two important features:
 
 This way we specified which component needs to be compiled given a source file for our whole project.
 
+If you use both, multiple components and an alternate `stack.yaml` file, there is a way to specify defaults
+for the path-specific configurations.
+
+```yaml
+cradle:
+  stack:
+    stackYaml: "stack-8.3.3.yaml"
+    components:
+    - path: "./src"
+      component: "hie-bios:lib"
+    - path: "./exe"
+      component: "hie-bios:exe:hie-bios"
+    - path: "./tests/BiosTests.hs"
+      component: "hie-bios:test:hie-bios"
+    - path: "./tests/ParserTests.hs"
+      component: "hie-bios:test:parser-tests"
+```
+
+A word of warning: Due to current restrictions in the language server, as mentioned in [this bug report](https://github.com/haskell/haskell-language-server/issues/268#issuecomment-667640809) all referenced stack.yaml files must specify the same version of GHC, as only one version of ghcide is loaded at a time. This restriction might be lifted in the future.
+
 #### Debugging a `stack` cradle
 
 If you find that `hie-bios` can't load a certain component or file, run `stack repl` and `stack repl <component name>` to see if `stack` succeeds in building your project. Chances are that there is a problem in your project and if you fix that, `hie-bios` will succeed to load it.

hie-bios.cabal

@@ -31,12 +31,15 @@ Extra-Source-Files:     ChangeLog.md
                         tests/configs/direct.yaml
                         tests/configs/multi.yaml
                         tests/configs/multi-ch.yaml
+                        tests/configs/multi-stack-with-yaml.yaml
                         tests/configs/nested-cabal-multi.yaml
                         tests/configs/nested-stack-multi.yaml
                         tests/configs/none.yaml
                         tests/configs/obelisk.yaml
                         tests/configs/stack-config.yaml
                         tests/configs/stack-multi.yaml
+                        tests/configs/stack-with-both.yaml
+                        tests/configs/stack-with-yaml.yaml
                         tests/projects/symlink-test/a/A.hs
                         tests/projects/symlink-test/hie.yaml
                         tests/projects/multi-direct/A.hs
@@ -145,7 +148,18 @@ Extra-Source-Files:     ChangeLog.md
                         tests/projects/implicit-stack-multi/other-package/Setup.hs
                         tests/projects/implicit-stack-multi/other-package/other-package.cabal
                         tests/projects/implicit-stack-multi/other-package/Main.hs
-
+                        tests/projects/multi-stack-with-yaml/appA/Setup.hs
+                        tests/projects/multi-stack-with-yaml/appA/appA.cabal
+                        tests/projects/multi-stack-with-yaml/appA/src/Lib.hs
+                        tests/projects/multi-stack-with-yaml/appB/Setup.hs
+                        tests/projects/multi-stack-with-yaml/appB/appB.cabal
+                        tests/projects/multi-stack-with-yaml/appB/src/Lib.hs
+                        tests/projects/multi-stack-with-yaml/hie.yaml
+                        tests/projects/stack-with-yaml/Setup.hs
+                        tests/projects/stack-with-yaml/app/Main.hs
+                        tests/projects/stack-with-yaml/hie.yaml
+                        tests/projects/stack-with-yaml/stack-with-yaml.cabal
+                        tests/projects/stack-with-yaml/src/Lib.hs
 
 tested-with: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4
 

src/HIE/Bios/Config.hs

@@ -2,21 +2,43 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
 -- | Logic and datatypes for parsing @hie.yaml@ files.
 module HIE.Bios.Config(
     readConfig,
     Config(..),
     CradleConfig(..),
+    CabalType,
+    pattern CabalType,
+    cabalComponent,
+    StackType,
+    pattern StackType,
+    stackComponent,
+    stackYaml,
     CradleType(..),
     Callable(..)
     ) where
 
 import qualified Data.Text as T
 import qualified Data.Vector as V
 import qualified Data.HashMap.Strict as Map
+import           Data.Semigroup
 import           Data.Foldable (foldrM)
 import           Data.Yaml
 
+type MLast a = Maybe (Last a)
+
+viewLast :: MLast a -> Maybe a
+viewLast (Just l) = Just $ getLast l
+viewLast Nothing = Nothing
+
+pattern MLast :: Maybe a -> MLast a
+pattern MLast m <- (viewLast -> m) where
+    MLast (Just l) = Just $ Last l
+    MLast Nothing = Nothing
+
 -- | Configuration that can be used to load a 'Cradle'.
 -- A configuration has roughly the following form:
 --
@@ -43,11 +65,45 @@ data CradleConfig a =
 data Callable = Program FilePath | Command String
     deriving (Show, Eq)
 
+data CabalType
+    = CabalType_ { _cabalComponent :: !(MLast String) }
+    deriving (Eq)
+
+instance Semigroup CabalType where
+    CabalType_ cr <> CabalType_ cl = CabalType_ (cr <> cl)
+
+instance Monoid CabalType where
+    mempty = CabalType_ mempty
+
+pattern CabalType :: Maybe String -> CabalType
+pattern CabalType { cabalComponent } = CabalType_ (MLast cabalComponent)
+{-# COMPLETE CabalType #-}
+
+instance Show CabalType where
+  show = show . Cabal
+
+data StackType
+    = StackType_ { _stackComponent :: !(MLast String) , _stackYaml :: !(MLast String) }
+    deriving (Eq)
+
+instance Semigroup StackType where
+    StackType_ cr yr <> StackType_ cl yl = StackType_ (cr <> cl) (yr <> yl)
+
+instance Monoid StackType where
+    mempty = StackType_ mempty mempty
+
+pattern StackType :: Maybe String -> Maybe String -> StackType
+pattern StackType { stackComponent, stackYaml } = StackType_ (MLast stackComponent) (MLast stackYaml)
+{-# COMPLETE StackType #-}
+
+instance Show StackType where
+  show = show . Stack
+
 data CradleType a
-    = Cabal { component :: Maybe String }
-    | CabalMulti [ (FilePath, String) ]
-    | Stack { component :: Maybe String }
-    | StackMulti [ (FilePath, String) ]
+    = Cabal { cabalType :: !CabalType }
+    | CabalMulti { defaultCabal :: !CabalType, subCabalComponents :: [ (FilePath, CabalType) ] }
+    | Stack { stackType :: !StackType }
+    | StackMulti { defaultStack :: !StackType, subStackComponents :: [ (FilePath, StackType) ] }
 --  Bazel and Obelisk used to be supported but bit-rotted and no users have complained.
 --  They can be added back if a user
 --    | Bazel
@@ -73,10 +129,10 @@ instance FromJSON a => FromJSON (CradleType a) where
     parseJSON _ = fail "Not a known cradle type. Possible are: cabal, stack, bios, direct, default, none, multi"
 
 instance Show (CradleType a) where
-    show (Cabal comp) = "Cabal {component = " ++ show comp ++ "}"
-    show (CabalMulti a) = "CabalMulti " ++ show a
-    show (Stack comp) = "Stack {component = " ++ show comp ++ "}"
-    show (StackMulti a) = "StackMulti " ++ show a
+    show (Cabal comp) = "Cabal {component = " ++ show (cabalComponent comp) ++ "}"
+    show (CabalMulti d a) = "CabalMulti {defaultCabal = " ++ show d ++ ", subCabalComponents = " ++ show a ++ "}"
+    show (Stack comp) = "Stack {component = " ++ show (stackComponent comp) ++ ", stackYaml = " ++ show (stackYaml comp) ++ "}"
+    show (StackMulti d a) = "StackMulti {defaultStack = " ++ show d ++ ", subStackComponents = "  ++ show a ++ "}"
     show Bios { call, depsCall } = "Bios {call = " ++ show call ++ ", depsCall = " ++ show depsCall ++ "}"
     show (Direct args) = "Direct {arguments = " ++ show args ++ "}"
     show None = "None"
@@ -96,38 +152,61 @@ parseCradleType o
     | Just val  <- Map.lookup "other" o = Other <$> parseJSON val <*> pure val
 parseCradleType o = fail $ "Unknown cradle type: " ++ show o
 
-parseStackOrCabal
-  :: (Maybe String -> CradleType a)
-  -> ([(FilePath, String)] -> CradleType a)
+parseSingleOrMultiple
+  :: Monoid x
+  => (x -> CradleType a)
+  -> (x -> [(FilePath, x)] -> CradleType a)
+  -> (Map.HashMap T.Text Value -> Parser x)
   -> Value
   -> Parser (CradleType a)
-parseStackOrCabal singleConstructor _ (Object x)
-  | Map.size x == 1, Just (String stackComponent) <- Map.lookup "component" x
-  = return $ singleConstructor $ Just $ T.unpack stackComponent
-  | Map.null x
-  = return $ singleConstructor Nothing
-  | otherwise
-  = fail "Not a valid Configuration type, following keys are allowed: component"
-parseStackOrCabal _ multiConstructor (Array x) = do
-  let parseOne e
+parseSingleOrMultiple single multiple parse = doParse where
+    parseOne e
         | Object v <- e
         , Just (String prefix) <- Map.lookup "path" v
-        , Just (String comp) <- Map.lookup "component" v
-        , Map.size v == 2
-        = return (T.unpack prefix, T.unpack comp)
+        = (T.unpack prefix,) <$> parse (Map.delete "path" v)
         | otherwise
-        = fail "Expected an object with path and component keys"
-
-  xs <- foldrM (\v cs -> (: cs) <$> parseOne v) [] x
-  return $ multiConstructor xs
-parseStackOrCabal singleConstructor _ Null = return $ singleConstructor Nothing
-parseStackOrCabal _ _ _ = fail "Configuration is expected to be an object."
+        = fail "Expected an object with a path key"
+    parseArray = foldrM (\v cs -> (: cs) <$> parseOne v) []
+    doParse (Object v)
+        | Just (Array x) <- Map.lookup "components" v
+        = do
+            d <- parse (Map.delete "components" v)
+            xs <- parseArray x
+            return $ multiple d xs
+        | Just _ <- Map.lookup "components" v
+        = fail "Expected components to be an array of subcomponents"
+        | Nothing <- Map.lookup "components" v
+        = single <$> parse v
+    doParse (Array x)
+        = do
+            xs <- parseArray x
+            return $ multiple mempty xs
+    doParse Null = single <$> parse Map.empty
+    doParse _ = fail "Configuration is expected to be an object or an array of objects."
 
 parseStack :: Value -> Parser (CradleType a)
-parseStack = parseStackOrCabal Stack StackMulti
+parseStack = parseSingleOrMultiple Stack StackMulti $
+  \case x | Map.size x == 2
+          , Just (String component) <- Map.lookup "component" x
+          , Just (String syaml) <- Map.lookup "stackYaml" x
+          -> return $ StackType (Just $ T.unpack component) (Just $ T.unpack syaml)
+          | Map.size x == 1, Just (String component) <- Map.lookup "component" x
+          -> return $ StackType (Just $ T.unpack component) Nothing
+          | Map.size x == 1, Just (String syaml) <- Map.lookup "stackYaml" x
+          -> return $ StackType Nothing (Just $ T.unpack syaml)
+          | Map.null x
+          -> return $ StackType Nothing Nothing
+          | otherwise
+          -> fail "Not a valid Stack configuration, following keys are allowed: component, stackYaml"
 
 parseCabal :: Value -> Parser (CradleType a)
-parseCabal = parseStackOrCabal Cabal CabalMulti
+parseCabal = parseSingleOrMultiple Cabal CabalMulti $
+  \case x | Map.size x == 1, Just (String component) <- Map.lookup "component" x
+          -> return $ CabalType (Just $ T.unpack component)
+          | Map.null x
+          -> return $ CabalType Nothing
+          | otherwise
+          -> fail "Not a valid Cabal configuration, following keys are allowed: component"
 
 parseBios :: Value -> Parser (CradleType a)
 parseBios (Object x) =
@@ -206,4 +285,4 @@ instance FromJSON a => FromJSON (Config a) where
 -- If the contents of the file is not a valid 'Config a',
 -- an 'Control.Exception.IOException' is thrown.
 readConfig :: FromJSON a => FilePath -> IO (Config a)
-readConfig = decodeFileThrow
+readConfig = decodeFileThrow