Allow specifying a stack.yaml for stack configurations

src/HIE/Bios/Config.hs

@@ -2,12 +2,18 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE LambdaCase #-}
 -- | Logic and datatypes for parsing @hie.yaml@ files.
 module HIE.Bios.Config(
     readConfig,
     Config(..),
     CradleConfig(..),
+    CabalType(..),
+    StackType(..),
     CradleType(..),
+    pattern Cabal,
+    pattern Stack,
     Callable(..)
     ) where
 
@@ -43,11 +49,25 @@ data CradleConfig a =
 data Callable = Program FilePath | Command String
     deriving (Show, Eq)
 
+data CabalType
+    = CabalType { cabalComponent :: Maybe String }
+    deriving (Eq)
+
+instance Show CabalType where
+  show = show . Cabal_
+
+data StackType
+    = StackType { stackComponent :: Maybe String , stackYaml :: Maybe String }
+    deriving (Eq)
+
+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 [ (FilePath, CabalType) ]
+    | Stack_ { stackType :: !StackType }
+    | StackMulti [ (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
@@ -66,14 +86,22 @@ 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) = "Stack {component = " ++ show comp ++ "}"
+    show (Stack comp yaml) = "Stack {component = " ++ show comp ++ ", stackYaml = " ++ show yaml ++ "}"
     show (StackMulti a) = "StackMulti " ++ show a
     show Bios { call, depsCall } = "Bios {call = " ++ show call ++ ", depsCall = " ++ show depsCall ++ "}"
     show (Direct args) = "Direct {arguments = " ++ show args ++ "}"
@@ -94,38 +122,48 @@ 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
+  :: (x -> CradleType a)
+  -> ([(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
+parseSingleOrMultiple single _ parse (Object v) = single <$> parse v
+parseSingleOrMultiple _ multiple parse (Array x) = do
   let 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"
-
+        = fail "Expected an object with a path key"
   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."
+  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."
 
 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 stackYaml) <- Map.lookup "stackYaml" x
+          -> return $ StackType (Just $ T.unpack component) (Just $ T.unpack stackYaml)
+          | 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.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)

src/HIE/Bios/Cradle.hs

@@ -96,13 +96,13 @@ getCradle buildCustomCradle (cc, wdir) = addCradleDeps cradleDeps $ case cradleT
     CabalMulti ms ->
       getCradle buildCustomCradle $
         (CradleConfig cradleDeps
-          (Multi [(p, CradleConfig [] (Cabal (Just c))) | (p, c) <- ms])
+          (Multi [(p, CradleConfig [] (Cabal_ c)) | (p, c) <- ms])
         , wdir)
-    Stack mc -> stackCradle wdir mc
+    Stack mc syaml -> stackCradle wdir mc (maybe "stack.yaml" id syaml)
     StackMulti ms ->
       getCradle buildCustomCradle $
         (CradleConfig cradleDeps
-          (Multi [(p, CradleConfig [] (Stack (Just c))) | (p, c) <- ms])
+          (Multi [(p, CradleConfig [] (Stack_ c)) | (p, c) <- ms])
         , wdir)
  --   Bazel -> rulesHaskellCradle wdir
  --   Obelisk -> obeliskCradle wdir
@@ -142,7 +142,7 @@ implicitConfig' fp = (\wdir ->
          (Bios (Program $ wdir </> ".hie-bios") Nothing, wdir)) <$> biosWorkDir fp
   --   <|> (Obelisk,) <$> obeliskWorkDir fp
   --   <|> (Bazel,) <$> rulesHaskellWorkDir fp
-     <|> (stackExecutable >> (Stack Nothing,) <$> stackWorkDir fp)
+     <|> (stackExecutable >> (Stack Nothing Nothing,) <$> stackWorkDir fp)
      <|> ((Cabal Nothing,) <$> cabalWorkDir fp)
 
 
@@ -552,16 +552,16 @@ cabalWorkDir wdir =
 ------------------------------------------------------------------------
 -- | Stack Cradle
 -- Works for by invoking `stack repl` with a wrapper script
-stackCradle :: FilePath -> Maybe String -> Cradle a
-stackCradle wdir mc =
+stackCradle :: FilePath -> Maybe String -> FilePath -> Cradle a
+stackCradle wdir mc syaml =
   Cradle
     { cradleRootDir    = wdir
     , cradleOptsProg   = CradleAction
         { actionName = Types.Stack
-        , runCradle = stackAction wdir mc
+        , runCradle = stackAction wdir mc syaml
         , runGhcCmd = \args ->
             readProcessWithCwd
-              wdir "stack" (["exec", "--silent", "ghc", "--"] <> args) ""
+              wdir "stack" (["--stack-yaml", syaml, "exec", "--silent", "ghc", "--"] <> args) ""
         }
     }
 
@@ -574,32 +574,32 @@ stackCradle wdir mc =
 -- a '.cabal' file.
 --
 -- Found dependencies are relative to 'rootDir'.
-stackCradleDependencies :: FilePath -> FilePath -> IO [FilePath]
-stackCradleDependencies wdir componentDir = do
+stackCradleDependencies :: FilePath -> FilePath -> FilePath -> IO [FilePath]
+stackCradleDependencies wdir componentDir syaml = do
   let relFp = makeRelative wdir componentDir
   cabalFiles' <- findCabalFiles componentDir
   let cabalFiles = map (relFp </>) cabalFiles'
-  return $ map normalise $ cabalFiles ++ [relFp </> "package.yaml", "stack.yaml"]
+  return $ map normalise $ cabalFiles ++ [relFp </> "package.yaml", syaml]
 
-stackAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)
-stackAction work_dir mc l _fp = do
-  let ghcProcArgs = ("stack", ["exec", "ghc", "--"])
+stackAction :: FilePath -> Maybe String -> FilePath -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)
+stackAction work_dir mc syaml l _fp = do
+  let ghcProcArgs = ("stack", ["--stack-yaml", syaml, "exec", "ghc", "--"])
   -- Same wrapper works as with cabal
   withCabalWrapperTool ghcProcArgs work_dir $ \wrapper_fp -> do
     (ex1, _stdo, stde, args) <-
       readProcessWithOutputFile l work_dir $
-        proc "stack" $ ["repl", "--no-nix-pure", "--with-ghc", wrapper_fp]
+        proc "stack" $ ["--stack-yaml", syaml, "repl", "--no-nix-pure", "--with-ghc", wrapper_fp]
                        ++ [ comp | Just comp <- [mc] ]
     (ex2, pkg_args, stdr, _) <-
       readProcessWithOutputFile l work_dir $
-        proc "stack" ["path", "--ghc-package-path"]
+        proc "stack" ["--stack-yaml", syaml, "path", "--ghc-package-path"]
     let split_pkgs = concatMap splitSearchPath pkg_args
         pkg_ghc_args = concatMap (\p -> ["-package-db", p] ) split_pkgs
     case processCabalWrapperArgs args of
         Nothing -> do
           -- Best effort. Assume the working directory is the
           -- the root of the component, so we are right in trivial cases at least.
-          deps <- stackCradleDependencies work_dir work_dir
+          deps <- stackCradleDependencies work_dir work_dir syaml
           pure $ CradleFail
                     (CradleError deps ex1 $
                       [ "Failed to parse result of calling stack" ]
@@ -608,7 +608,7 @@ stackAction work_dir mc l _fp = do
                     )
 
         Just (componentDir, ghc_args) -> do
-          deps <- stackCradleDependencies work_dir componentDir
+          deps <- stackCradleDependencies work_dir componentDir syaml
           pure $ makeCradleResult
                     ( combineExitCodes [ex1, ex2]
                     , stde ++ stdr, componentDir

tests/ParserTests.hs

@@ -18,7 +18,7 @@ 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))
+    assertParser "stack-config.yaml" (noDeps (Stack 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"))))
@@ -32,21 +32,21 @@ main = defaultMain $
     assertParser "multi.yaml" (noDeps (Multi [("./src", CradleConfig [] (Cabal (Just "lib:hie-bios")))
                                              , ("./test", CradleConfig [] (Cabal (Just "test")) ) ]))
 
-    assertParser "cabal-multi.yaml" (noDeps (CabalMulti [("./src", "lib:hie-bios")
-                                                    ,("./", "lib:hie-bios")]))
+    assertParser "cabal-multi.yaml" (noDeps (CabalMulti [("./src", CabalType $ Just "lib:hie-bios")
+                                                        ,("./", CabalType $ Just "lib:hie-bios")]))
 
-    assertParser "stack-multi.yaml" (noDeps (StackMulti [("./src", "lib:hie-bios")
-                                                    ,("./", "lib:hie-bios")]))
+    assertParser "stack-multi.yaml" (noDeps (StackMulti [("./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", "lib:hie-bios")
-                                                                               ,("./tests", "parser-tests")]))]))
+                                                                    CabalMulti [("./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", "lib:hie-bios")
-                                                                              ,("./tests", "parser-tests")]))]))
+                                                                    StackMulti [("./src", StackType (Just "lib:hie-bios") Nothing)
+                                                                              ,("./tests", StackType (Just "parser-tests") Nothing)]))]))
 
     assertCustomParser "ch-cabal.yaml"
       (noDeps (Other CabalHelperCabal $ simpleCabalHelperYaml "cabal"))