Allow specifying a stack.yaml for stack configurations

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,24 @@ 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"
+```
+
 #### 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

@@ -151,7 +151,7 @@ Extra-Source-Files:     ChangeLog.md
                         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/multi-stack.cabal
+                        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

@@ -3,26 +3,42 @@
 {-# 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(..),
-    StackType(..),
+    CabalType,
+    pattern CabalType,
+    cabalComponent,
+    StackType,
+    pattern StackType,
+    stackComponent,
+    stackYaml,
     CradleType(..),
-    pattern Cabal,
-    pattern Stack,
     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:
 --
@@ -50,24 +66,44 @@ data Callable = Program FilePath | Command String
     deriving (Show, Eq)
 
 data CabalType
-    = CabalType { cabalComponent :: Maybe String }
+    = 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_
+  show = show . Cabal
 
 data StackType
-    = StackType { stackComponent :: Maybe String , stackYaml :: Maybe String }
+    = 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_
+  show = show . Stack
 
 data CradleType a
-    = Cabal_ { cabalType :: !CabalType }
-    | CabalMulti [ (FilePath, CabalType) ]
-    | Stack_ { stackType :: !StackType }
-    | StackMulti [ (FilePath, StackType) ]
+    = 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
@@ -86,23 +122,15 @@ data CradleType a
     | Other { otherConfig :: a, originalYamlValue :: Value }
     deriving (Eq, Functor)
 
-pattern Cabal :: Maybe String -> CradleType a
-pattern Cabal cm = Cabal_ (CabalType cm)
-
-pattern Stack :: Maybe String -> Maybe String -> CradleType a
-pattern Stack cm yml = Stack_ (StackType cm yml)
-
-{-# COMPLETE Cabal, CabalMulti, Stack, StackMulti, Bios, Direct, None, Multi, Other :: CradleType #-}
-
 instance FromJSON a => FromJSON (CradleType a) where
     parseJSON (Object o) = parseCradleType o
     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 yaml) = "Stack {component = " ++ show comp ++ ", stackYaml = " ++ show yaml ++ "}"
-    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"
@@ -123,41 +151,54 @@ parseCradleType o
 parseCradleType o = fail $ "Unknown cradle type: " ++ show o
 
 parseSingleOrMultiple
-  :: (x -> CradleType a)
-  -> ([(FilePath, x)] -> CradleType a)
+  :: Monoid x
+  => (x -> CradleType a)
+  -> (x -> [(FilePath, x)] -> CradleType a)
   -> (Map.HashMap T.Text Value -> Parser x)
   -> Value
   -> Parser (CradleType a)
-parseSingleOrMultiple single _ parse (Object v) = single <$> parse v
-parseSingleOrMultiple _ multiple parse (Array x) = do
-  let parseOne e
+parseSingleOrMultiple single multiple parse = doParse where
+    parseOne e
         | Object v <- e
         , Just (String prefix) <- Map.lookup "path" v
         = (T.unpack prefix,) <$> parse (Map.delete "path" v)
         | otherwise
         = fail "Expected an object with a path key"
-  xs <- foldrM (\v cs -> (: cs) <$> parseOne v) [] x
-  return $ multiple xs
-parseSingleOrMultiple single _ parse Null = single <$> parse Map.empty
-parseSingleOrMultiple _ _ _ _ = fail "Configuration is expected to be an object or an array of objects."
+    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 = parseSingleOrMultiple Stack_ StackMulti $
+parseStack = parseSingleOrMultiple Stack StackMulti $
   \case x | Map.size x == 2
           , Just (String component) <- Map.lookup "component" x
-          , Just (String stackYaml) <- Map.lookup "stackYaml" x
-          -> return $ StackType (Just $ T.unpack component) (Just $ T.unpack stackYaml)
+          , 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 stackYaml) <- Map.lookup "stackYaml" x
-          -> return $ StackType Nothing (Just $ T.unpack stackYaml)
+          | 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 = parseSingleOrMultiple 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
@@ -239,4 +280,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

src/HIE/Bios/Cradle.hs

@@ -93,17 +93,17 @@ loadCradleWithOpts _copts buildCustomCradle wfile = do
 
 getCradle :: (b -> Cradle a) -> (CradleConfig b, FilePath) -> Cradle a
 getCradle buildCustomCradle (cc, wdir) = addCradleDeps cradleDeps $ case cradleType cc of
-    Cabal mc -> cabalCradle wdir mc
-    CabalMulti ms ->
+    Cabal CabalType{ cabalComponent = mc } -> cabalCradle wdir mc
+    CabalMulti dc ms ->
       getCradle buildCustomCradle $
         (CradleConfig cradleDeps
-          (Multi [(p, CradleConfig [] (Cabal_ c)) | (p, c) <- ms])
+          (Multi [(p, CradleConfig [] (Cabal $ dc <> c)) | (p, c) <- ms])
         , wdir)
-    Stack mc syaml -> stackCradle wdir mc (maybe "stack.yaml" id syaml)
-    StackMulti ms ->
+    Stack StackType{ stackComponent = mc, stackYaml = syaml} -> stackCradle wdir mc (maybe "stack.yaml" id syaml)
+    StackMulti ds ms ->
       getCradle buildCustomCradle $
         (CradleConfig cradleDeps
-          (Multi [(p, CradleConfig [] (Stack_ c)) | (p, c) <- ms])
+          (Multi [(p, CradleConfig [] (Stack $ ds <> c)) | (p, c) <- ms])
         , wdir)
  --   Bazel -> rulesHaskellCradle wdir
  --   Obelisk -> obeliskCradle wdir
@@ -143,8 +143,8 @@ implicitConfig' fp = (\wdir ->
          (Bios (Program $ wdir </> ".hie-bios") Nothing, wdir)) <$> biosWorkDir fp
   --   <|> (Obelisk,) <$> obeliskWorkDir fp
   --   <|> (Bazel,) <$> rulesHaskellWorkDir fp
-     <|> (stackExecutable >> (Stack Nothing Nothing,) <$> stackWorkDir fp)
-     <|> ((Cabal Nothing,) <$> cabalWorkDir fp)
+     <|> (stackExecutable >> (Stack $ StackType Nothing Nothing,) <$> stackWorkDir fp)
+     <|> ((Cabal $ CabalType Nothing,) <$> cabalWorkDir fp)
 
 
 yamlConfig :: FilePath ->  MaybeT IO FilePath

tests/ParserTests.hs

@@ -17,43 +17,48 @@ configDir = "tests/configs"
 main :: IO ()
 main = defaultMain $
   testCase "Parser Tests" $ do
-    assertParser "cabal-1.yaml" (noDeps (Cabal (Just "lib:hie-bios")))
-    assertParser "stack-config.yaml" (noDeps (Stack Nothing Nothing))
+    assertParser "cabal-1.yaml" (noDeps (Cabal $ CabalType (Just "lib:hie-bios")))
+    assertParser "stack-config.yaml" (noDeps (Stack $ StackType Nothing Nothing))
     --assertParser "bazel.yaml" (noDeps Bazel)
     assertParser "bios-1.yaml" (noDeps (Bios (Program "program") Nothing))
     assertParser "bios-2.yaml" (noDeps (Bios (Program "program") (Just (Program "dep-program"))))
     assertParser "bios-3.yaml" (noDeps (Bios (Command "shellcommand") Nothing))
     assertParser "bios-4.yaml" (noDeps (Bios (Command "shellcommand") (Just (Command "dep-shellcommand"))))
     assertParser "bios-5.yaml" (noDeps (Bios (Command "shellcommand") (Just (Program "dep-program"))))
-    assertParser "dependencies.yaml" (Config (CradleConfig ["depFile"] (Cabal (Just "lib:hie-bios"))))
+    assertParser "dependencies.yaml" (Config (CradleConfig ["depFile"] (Cabal $ CabalType (Just "lib:hie-bios"))))
     assertParser "direct.yaml" (noDeps (Direct ["list", "of", "arguments"]))
     assertParser "none.yaml" (noDeps None)
     --assertParser "obelisk.yaml" (noDeps Obelisk)
-    assertParser "multi.yaml" (noDeps (Multi [("./src", CradleConfig [] (Cabal (Just "lib:hie-bios")))
-                                             , ("./test", CradleConfig [] (Cabal (Just "test")) ) ]))
+    assertParser "multi.yaml" (noDeps (Multi [("./src", CradleConfig [] (Cabal $ CabalType (Just "lib:hie-bios")))
+                                             ,("./test", CradleConfig [] (Cabal $ CabalType (Just "test")) ) ]))
 
-    assertParser "cabal-multi.yaml" (noDeps (CabalMulti [("./src", CabalType $ Just "lib:hie-bios")
+    assertParser "cabal-multi.yaml" (noDeps (CabalMulti (CabalType Nothing)
+                                                        [("./src", CabalType $ Just "lib:hie-bios")
                                                         ,("./", CabalType $ Just "lib:hie-bios")]))
 
-    assertParser "stack-multi.yaml" (noDeps (StackMulti [("./src", StackType (Just "lib:hie-bios") Nothing)
+    assertParser "stack-multi.yaml" (noDeps (StackMulti (StackType Nothing Nothing)
+                                                        [("./src", StackType (Just "lib:hie-bios") Nothing)
                                                         ,("./", StackType (Just"lib:hie-bios") Nothing)]))
 
     assertParser "nested-cabal-multi.yaml" (noDeps (Multi [("./test/testdata", CradleConfig [] None)
                                                           ,("./", CradleConfig [] (
-                                                                    CabalMulti [("./src", CabalType $ Just "lib:hie-bios")
+                                                                    CabalMulti (CabalType Nothing)
+                                                                               [("./src", CabalType $ Just "lib:hie-bios")
                                                                                ,("./tests", CabalType $ Just "parser-tests")]))]))
 
     assertParser "nested-stack-multi.yaml" (noDeps (Multi [("./test/testdata", CradleConfig [] None)
                                                           ,("./", CradleConfig [] (
-                                                                    StackMulti [("./src", StackType (Just "lib:hie-bios") Nothing)
-                                                                              ,("./tests", StackType (Just "parser-tests") Nothing)]))]))
+                                                                    StackMulti (StackType Nothing Nothing)
+                                                                               [("./src", StackType (Just "lib:hie-bios") Nothing)
+                                                                               ,("./tests", StackType (Just "parser-tests") Nothing)]))]))
     assertParser "stack-with-yaml.yaml"
-      (noDeps (Stack Nothing (Just "stack-8.8.3.yaml")))
+      (noDeps (Stack $ StackType Nothing (Just "stack-8.8.3.yaml")))
     assertParser "stack-with-both.yaml"
-      (noDeps (Stack (Just "hie-bios:hie") (Just "stack-8.8.3.yaml")))
+      (noDeps (Stack $ StackType (Just "hie-bios:hie") (Just "stack-8.8.3.yaml")))
     assertParser "multi-stack-with-yaml.yaml"
-      (noDeps (StackMulti [("./src", StackType Nothing $ Just "stack-8.8.3.yaml")
-                          ,("./vendor", StackType Nothing $ Just "./vendor/stack-8.8.3.yaml")]))
+      (noDeps (StackMulti (StackType Nothing (Just "stack-8.8.3.yaml"))
+                          [("./src", StackType (Just "lib:hie-bios") Nothing)
+                          ,("./vendor", StackType (Just "parser-tests") Nothing)]))
 
     assertCustomParser "ch-cabal.yaml"
       (noDeps (Other CabalHelperCabal $ simpleCabalHelperYaml "cabal"))
@@ -63,7 +68,7 @@ main = defaultMain $
       (noDeps (Multi
         [ ("./src", CradleConfig [] (Other CabalHelperStack $ simpleCabalHelperYaml "stack"))
         , ("./input", CradleConfig [] (Other CabalHelperCabal $ simpleCabalHelperYaml "cabal"))
-        , ("./test", CradleConfig [] (Cabal (Just "test")))
+        , ("./test", CradleConfig [] (Cabal $ CabalType (Just "test")))
         , (".", CradleConfig [] None)
         ]))
 

tests/configs/multi-stack-with-yaml.yaml

@@ -1,6 +1,8 @@
 cradle:
   stack:
-    - path: "./src"
-      stackYaml: "stack-8.8.3.yaml"
-    - path: "./vendor"
-      stackYaml: "./vendor/stack-8.8.3.yaml"
+    stackYaml: "stack-8.8.3.yaml"
+    components:
+      - path: "./src"
+        component: "lib:hie-bios"
+      - path: "./vendor"
+        component: "parser-tests" 

tests/projects/stack-with-yaml/hie.yaml

@@ -1,9 +1,9 @@
 cradle:
   stack:
-      - path: ./src
-        component: "multi-stack:lib"
-        stackYaml: "stack-alt.yaml"
+    stackYaml: "stack-alt.yaml"
+    components:
+    - path: ./src
+      component: "stack-with-yaml:lib"
 
-      - path: ./app
-        component: "multi-stack:exe:multi-stack"
-        stackYaml: "stack-alt.yaml"
+    - path: ./app
+      component: "stack-with-yaml:exe:stack-with-yaml"