hie-bios 0.3.2 → 0.4.0

raw patch · 38 files changed

+667/−212 lines, 38 filesdep +aesondep ~extradep ~ghcdep ~textnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson

Dependency ranges changed: extra, ghc, text, unordered-containers, yaml

API changes (from Hackage documentation)

Files

• ChangeLog +19/−0
• README.md +1/−1
• exe/Main.hs +6/−1
• hie-bios.cabal +30/−6
• src/HIE/Bios/Config.hs +51/−34
• src/HIE/Bios/Cradle.hs +179/−68
• src/HIE/Bios/Environment.hs +11/−2
• src/HIE/Bios/Flags.hs +1/−1
• src/HIE/Bios/Ghc/Api.hs +8/−8
• src/HIE/Bios/Ghc/Check.hs +3/−2
• src/HIE/Bios/Ghc/Gap.hs +10/−53
• src/HIE/Bios/Internal/Debug.hs +49/−4
• src/HIE/Bios/Types.hs +25/−12
• tests/BiosTests.hs +53/−18
• tests/ParserTests.hs +57/−2
• tests/configs/ch-cabal.yaml +4/−0
• tests/configs/ch-stack.yaml +4/−0
• tests/configs/multi-ch.yaml +10/−0
• tests/projects/implicit-cabal/Main.hs +4/−0
• tests/projects/implicit-cabal/Setup.hs +2/−0
• tests/projects/implicit-cabal/cabal.project +1/−0
• tests/projects/implicit-cabal/implicit-cabal.cabal +25/−0
• tests/projects/implicit-stack-multi/Main.hs +4/−0
• tests/projects/implicit-stack-multi/Setup.hs +2/−0
• tests/projects/implicit-stack-multi/implicit-stack-multi.cabal +25/−0
• tests/projects/implicit-stack-multi/other-package/Main.hs +4/−0
• tests/projects/implicit-stack-multi/other-package/Setup.hs +2/−0
• tests/projects/implicit-stack-multi/other-package/other-package.cabal +26/−0
• tests/projects/implicit-stack/Main.hs +4/−0
• tests/projects/implicit-stack/Setup.hs +2/−0
• tests/projects/implicit-stack/implicit-stack.cabal +25/−0
• tests/projects/multi-cabal/multi-cabal.cabal +1/−0
• tests/projects/multi-direct/A.hs +1/−0
• tests/projects/multi-direct/B.hs +3/−0
• tests/projects/multi-direct/hie.yaml +12/−0
• tests/projects/multi-stack/multi-stack.cabal +1/−0
• tests/projects/simple-cabal/simple-cabal.cabal +1/−0
• tests/projects/simple-stack/simple-stack.cabal +1/−0

@@ -1,3 +1,22 @@+2020-01-29 - 0.4.0++	* Return CompilerOptions in initialization (#130)+	* Implement hook into config parser (#131)+	* Enable GHC 8.8.1 windows ci (#128)+	* Catch permission errors in cradle discovery (#127)+	* Add explicit cradle predicates and multi cradle depend on its cradles (#119)+	* Fix outdated direct cradle in README (#124)+	* Pass filepath to cabal v2-repl when getting flags (#123)+	* CPP for GHC 8.10 compatibility (#134)+	* Derive Ord for ComponentOptions (#133)+	* Lower the required version of the GHC dependency (#138)+	* Add tests for implicit cradles (#135)+	* Add Functor instance for Cradle and ActionName (#140)+	* Remove Show instance from public API (#146)+	* Add Show instance for CradleLoadResult (#145)+	* Typo in debug message (#144)+	* Add lower bound for aeson and clean-up API (#142)+ 2019-12-19 - 0.3.2  	* Compile windows wrapper script in a a more appropiate directory. (#109)

@@ -67,7 +67,7 @@ will quickly get out of sync with a cabal file.  ```yaml-cradle: {direct: [arg1, arg2]}+cradle: {direct: { arguments: [arg1, arg2]} } ```  The `none` cradle says that the IDE shouldn't even try to load the project. It

@@ -35,6 +35,8 @@         ++ "\t hie-bios expand <HaskellFiles...>\n"         ++ "\t hie-bios flags <HaskellFiles...>\n"         ++ "\t hie-bios debug [<ComponentDir>]\n"+        ++ "\t hie-bios config <HaskellFiles...>\n"+        ++ "\t hie-bios cradle <HaskellFiles...>\n"         ++ "\t hie-bios root\n"         ++ "\t hie-bios version\n" @@ -55,7 +57,8 @@ main = flip E.catches handlers $ do     hSetEncoding stdout utf8     args <- getArgs-    cradle <- getCurrentDirectory >>= \cwd ->+    cwd <- getCurrentDirectory+    cradle <-         -- find cradle does a takeDirectory on the argument, so make it into a file         findCradle (cwd </> "File.hs") >>= \case           Just yaml -> loadCradle yaml@@ -69,6 +72,8 @@         | (fp:_) <- remainingArgs -> debugInfo fp cradle       "root"    -> rootInfo cradle       "version" -> return progVersion+      "config" -> configInfo remainingArgs+      "cradle" -> cradleInfo remainingArgs       "flags"         | null remainingArgs -> E.throw $ NotEnoughArguments cmdArg0         | otherwise -> do

@@ -1,6 +1,6 @@ Cabal-Version:          2.2 Name:                   hie-bios-Version:                0.3.2+Version:                0.4.0 Author:                 Matthew Pickering <matthewtpickering@gmail.com> Maintainer:             Matthew Pickering <matthewtpickering@gmail.com> License:                BSD-3-Clause@@ -21,16 +21,22 @@                         tests/configs/bios-2.yaml                         tests/configs/cabal-1.yaml                         tests/configs/cabal-multi.yaml+                        tests/configs/ch-cabal.yaml+                        tests/configs/ch-stack.yaml                         tests/configs/default.yaml                         tests/configs/dependencies.yaml                         tests/configs/direct.yaml                         tests/configs/multi.yaml+                        tests/configs/multi-ch.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/projects/multi-direct/A.hs+                        tests/projects/multi-direct/B.hs+                        tests/projects/multi-direct/hie.yaml                         tests/projects/multi-cabal/Setup.hs                         tests/projects/multi-cabal/app/Main.hs                         tests/projects/multi-cabal/cabal.project@@ -64,9 +70,22 @@                         tests/projects/simple-stack/cabal.project                         tests/projects/simple-stack/hie.yaml                         tests/projects/simple-stack/simple-stack.cabal+                        tests/projects/implicit-cabal/Setup.hs+                        tests/projects/implicit-cabal/cabal.project+                        tests/projects/implicit-cabal/implicit-cabal.cabal+                        tests/projects/implicit-cabal/Main.hs+                        tests/projects/implicit-stack/Setup.hs+                        tests/projects/implicit-stack/implicit-stack.cabal+                        tests/projects/implicit-stack/Main.hs+                        tests/projects/implicit-stack-multi/Setup.hs+                        tests/projects/implicit-stack-multi/implicit-stack-multi.cabal+                        tests/projects/implicit-stack-multi/Main.hs+                        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  -tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2+tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4  Library   Default-Language:     Haskell2010@@ -90,7 +109,8 @@   Other-Modules:        Paths_hie_bios   autogen-modules:      Paths_hie_bios   Build-Depends:-                        base >= 4.8 && < 5,+                        base                 >= 4.8 && < 5,+                        aeson                >= 1.4.1 && < 2,                         base16-bytestring    >= 0.1.1 && < 0.2,                         bytestring           >= 0.10.8 && < 0.11,                         deepseq              >= 1.4.3 && < 1.5,@@ -101,7 +121,7 @@                         time                 >= 1.8.0 && < 1.10,                         extra                >= 1.6.14 && < 1.7,                         process              >= 1.6.1 && < 1.7,-                        ghc                  >= 8.2.2 && < 8.9,+                        ghc                  >= 8.4.1 && < 8.9,                         transformers         >= 0.5.2 && < 0.6,                         temporary            >= 1.2 && < 1.4,                         text                 >= 1.2.3 && < 1.3,@@ -132,10 +152,13 @@   default-language: Haskell2010   build-depends:       base,+      filepath,+      hie-bios,       tasty,       tasty-hunit,-      hie-bios,-      filepath+      text,+      unordered-containers,+      yaml    hs-source-dirs: tests/   ghc-options: -threaded -Wall@@ -146,6 +169,7 @@   default-language: Haskell2010   build-depends:       base,+      extra,       tasty,       tasty-hunit,       hie-bios,

@@ -1,5 +1,7 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveFunctor #-} -- | Logic and datatypes for parsing @hie.yaml@ files. module HIE.Bios.Config(     readConfig,@@ -11,22 +13,33 @@ import qualified Data.Text as T import qualified Data.Vector as V import qualified Data.HashMap.Strict as Map-import Data.Foldable (foldrM)+import           Data.Foldable (foldrM) import           Data.Yaml -data CradleConfig =+-- | Configuration that can be used to load a 'Cradle'.+-- A configuration has roughly the following form:+--+-- @+-- cradle:+--   cabal:+--     component: "lib:hie-bios"+-- @+newtype Config a = Config { cradle :: CradleConfig a }+    deriving (Show, Eq, Functor)++data CradleConfig a =     CradleConfig         { cradleDependencies :: [FilePath]         -- ^ Dependencies of a cradle.         -- Dependencies are expected to be relative to the root directory.         -- The given files are not required to exist.-        , cradleType :: CradleType+        , cradleType :: CradleType a         -- ^ Type of the cradle to use. Actions to obtain         -- compiler flags from are dependant on this field.         }-        deriving (Show, Eq)+        deriving (Show, Eq, Functor) -data CradleType+data CradleType a     = Cabal { component :: Maybe String }     | CabalMulti [ (FilePath, String) ]     | Stack { component :: Maybe String }@@ -46,14 +59,26 @@         }     | Direct { arguments :: [String] }     | None-    | Multi [ (FilePath, CradleConfig) ]-    deriving (Show, Eq)+    | Multi [ (FilePath, CradleConfig a) ]+    | Other { otherConfig :: a, originalYamlValue :: Value }+    deriving (Eq, Functor) -instance FromJSON CradleType where+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" -parseCradleType :: Object -> Parser CradleType+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 Bios { prog, depsProg } = "Bios {prog = " ++ show prog ++ ", depsProg = " ++ show depsProg ++ "}"+    show (Direct args) = "Direct {arguments = " ++ show args ++ "}"+    show None = "None"+    show (Multi a) = "Multi " ++ show a+    show (Other _ val) = "Other {originalYamlValue = " ++ show val ++ "}"++parseCradleType :: FromJSON a => Object -> Parser (CradleType a) parseCradleType o     | Just val <- Map.lookup "cabal" o = parseCabal val     | Just val <- Map.lookup "stack" o = parseStack val@@ -63,13 +88,14 @@     | Just val <- Map.lookup "direct" o = parseDirect val     | Just _val <- Map.lookup "none" o = return None     | Just val  <- Map.lookup "multi" o = parseMulti val+    | Just val  <- Map.lookup "other" o = Other <$> parseJSON val <*> pure val parseCradleType o = fail $ "Unknown cradle type: " ++ show o  parseStackOrCabal-  :: (Maybe String -> CradleType)-  -> ([(FilePath, String)] -> CradleType)+  :: (Maybe String -> CradleType a)+  -> ([(FilePath, String)] -> CradleType a)   -> Value-  -> Parser CradleType+  -> Parser (CradleType a) parseStackOrCabal singleConstructor _ (Object x)   | Map.size x == 1, Just (String stackComponent) <- Map.lookup "component" x   = return $ singleConstructor $ Just $ T.unpack stackComponent@@ -92,13 +118,13 @@ parseStackOrCabal singleConstructor _ Null = return $ singleConstructor Nothing parseStackOrCabal _ _ _ = fail "Configuration is expected to be an object." -parseStack :: Value -> Parser CradleType+parseStack :: Value -> Parser (CradleType a) parseStack = parseStackOrCabal Stack StackMulti -parseCabal :: Value -> Parser CradleType+parseCabal :: Value -> Parser (CradleType a) parseCabal = parseStackOrCabal Cabal CabalMulti -parseBios :: Value -> Parser CradleType+parseBios :: Value -> Parser (CradleType a) parseBios (Object x)     | 2 == Map.size x     , Just (String biosProgram) <- Map.lookup "program" x@@ -113,7 +139,7 @@     = fail "Not a valid Bios Configuration type, following keys are allowed: program, dependency-program" parseBios _ = fail "Bios Configuration is expected to be an object." -parseDirect :: Value -> Parser CradleType+parseDirect :: Value -> Parser (CradleType a) parseDirect (Object x)     | Map.size x == 1     , Just (Array v) <- Map.lookup "arguments" x@@ -123,30 +149,19 @@     = fail "Not a valid Direct Configuration type, following keys are allowed: arguments" parseDirect _ = fail "Direct Configuration is expected to be an object." -parseMulti :: Value -> Parser CradleType+parseMulti :: FromJSON a => Value -> Parser (CradleType a) parseMulti (Array x)     = Multi <$> mapM parsePath (V.toList x) parseMulti _ = fail "Multi Configuration is expected to be an array." -parsePath :: Value -> Parser (FilePath, CradleConfig)+parsePath :: FromJSON a => Value -> Parser (FilePath, CradleConfig a) parsePath (Object v)   | Just (String path) <- Map.lookup "path" v   , Just c <- Map.lookup "config" v   = (T.unpack path,) <$> parseJSON c parsePath o = fail ("Multi component is expected to be an object." ++ show o) --- | Configuration that can be used to load a 'Cradle'.--- A configuration has roughly the following form:------ @--- cradle:---   cabal:---     component: "lib:hie-bios"--- @-newtype Config = Config { cradle :: CradleConfig }-    deriving (Show, Eq)--instance FromJSON CradleConfig where+instance FromJSON a => FromJSON (CradleConfig a) where     parseJSON (Object val) = do             crd     <- val .: "cradle"             crdDeps <- case Map.size val of@@ -161,12 +176,14 @@     parseJSON _ = fail "Expected a cradle: key containing the preferences, possible values: cradle, dependencies"  -instance FromJSON Config where+instance FromJSON a => FromJSON (Config a) where     parseJSON o = Config <$> parseJSON o  --- | Decode given file to a 'Config' value.--- If the contents of the file is not a valid 'Config',+-- | Decode given file to a 'Config a' value.+-- Type variable 'a' can be used to extend the 'hie.yaml' file format+-- to extend configuration in the user-library.+-- If the contents of the file is not a valid 'Config a', -- an 'Control.Exception.IOException' is thrown.-readConfig :: FilePath -> IO Config+readConfig :: FromJSON a => FilePath -> IO (Config a) readConfig = decodeFileThrow

@@ -1,16 +1,31 @@+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-} module HIE.Bios.Cradle (       findCradle     , loadCradle+    , loadCustomCradle     , loadImplicitCradle     , defaultCradle+    , isCabalCradle+    , isStackCradle+    , isDirectCradle+    , isBiosCradle+    , isNoneCradle+    , isMultiCradle+    , isDefaultCradle+    , isOtherCradle   ) where +import Control.Exception (handleJust)+import qualified Data.Yaml as Yaml+import Data.Void import System.Process import System.Exit-import HIE.Bios.Types+import HIE.Bios.Types hiding (ActionName(..))+import qualified HIE.Bios.Types as Types import HIE.Bios.Config+import HIE.Bios.Environment (getCacheDir) import System.Directory hiding (findFile) import Control.Monad.Trans.Maybe import System.FilePath@@ -20,6 +35,7 @@ import System.Environment import Control.Applicative ((<|>)) import System.IO.Temp+import System.IO.Error (isPermissionError) import Data.List import Data.Ord (Down(..)) @@ -28,16 +44,13 @@ import System.IO import Control.DeepSeq -import Data.Version (showVersion)-import Paths_hie_bios import Data.Conduit.Process import qualified Data.Conduit.Combinators as C import qualified Data.Conduit as C import qualified Data.Conduit.Text as C import qualified Data.Text as T-import           Data.Maybe                     ( maybeToList-                                                , fromMaybe-                                                )+import           Data.Maybe (fromMaybe)+import           GHC.Fingerprint (fingerprintString) ----------------------------------------------------------------  -- | Given root\/foo\/bar.hs, return root\/hie.yaml, or wherever the yaml file was found.@@ -47,38 +60,41 @@     runMaybeT (yamlConfig wdir)  -- | Given root\/hie.yaml load the Cradle.-loadCradle :: FilePath -> IO Cradle-loadCradle = loadCradleWithOpts defaultCradleOpts+loadCradle :: FilePath -> IO (Cradle Void)+loadCradle = loadCradleWithOpts Types.defaultCradleOpts absurd +loadCustomCradle :: Yaml.FromJSON b => (b -> Cradle a) -> FilePath -> IO (Cradle a)+loadCustomCradle = loadCradleWithOpts Types.defaultCradleOpts+ -- | Given root\/foo\/bar.hs, load an implicit cradle-loadImplicitCradle :: FilePath -> IO Cradle+loadImplicitCradle :: Show a => FilePath -> IO (Cradle a) loadImplicitCradle wfile = do   let wdir = takeDirectory wfile   cfg <- runMaybeT (implicitConfig wdir)   return $ case cfg of-    Just bc -> getCradle bc+    Just bc -> getCradle absurd bc     Nothing -> defaultCradle wdir  -- | Finding 'Cradle'. --   Find a cabal file by tracing ancestor directories. --   Find a sandbox according to a cabal sandbox config --   in a cabal directory.-loadCradleWithOpts :: CradleOpts -> FilePath -> IO Cradle-loadCradleWithOpts _copts wfile = do+loadCradleWithOpts :: (Yaml.FromJSON b) => CradleOpts -> (b -> Cradle a) -> FilePath -> IO (Cradle a)+loadCradleWithOpts _copts buildCustomCradle wfile = do     cradleConfig <- readCradleConfig wfile-    return $ getCradle (cradleConfig, takeDirectory wfile)+    return $ getCradle buildCustomCradle (cradleConfig, takeDirectory wfile) -getCradle :: (CradleConfig, FilePath) -> Cradle-getCradle (cc, wdir) = addCradleDeps cradleDeps $ case cradleType cc of+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 ->-      getCradle $+      getCradle buildCustomCradle $         (CradleConfig cradleDeps           (Multi [(p, CradleConfig [] (Cabal (Just c))) | (p, c) <- ms])         , wdir)     Stack mc -> stackCradle wdir mc     StackMulti ms ->-      getCradle $+      getCradle buildCustomCradle $         (CradleConfig cradleDeps           (Multi [(p, CradleConfig [] (Stack (Just c))) | (p, c) <- ms])         , wdir)@@ -87,26 +103,27 @@     Bios bios deps  -> biosCradle wdir bios deps     Direct xs -> directCradle wdir xs     None      -> noneCradle wdir-    Multi ms  -> multiCradle wdir ms+    Multi ms  -> multiCradle buildCustomCradle wdir ms+    Other a _ -> buildCustomCradle a     where       cradleDeps = cradleDependencies cc -addCradleDeps :: [FilePath] -> Cradle -> Cradle+addCradleDeps :: [FilePath] -> Cradle a -> Cradle a addCradleDeps deps c =   c { cradleOptsProg = addActionDeps (cradleOptsProg c) }   where-    addActionDeps :: CradleAction -> CradleAction+    addActionDeps :: CradleAction a -> CradleAction a     addActionDeps ca =       ca { runCradle = \l fp ->             (fmap (\(ComponentOptions os' ds) -> ComponentOptions os' (ds `union` deps)))               <$> runCradle ca l fp } -implicitConfig :: FilePath -> MaybeT IO (CradleConfig, FilePath)+implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath) implicitConfig fp = do   (crdType, wdir) <- implicitConfig' fp   return (CradleConfig [] crdType, wdir) -implicitConfig' :: FilePath -> MaybeT IO (CradleType, FilePath)+implicitConfig' :: FilePath -> MaybeT IO (CradleType a, FilePath) implicitConfig' fp = (\wdir ->          (Bios (wdir </> ".hie-bios") Nothing, wdir)) <$> biosWorkDir fp   --   <|> (Obelisk,) <$> obeliskWorkDir fp@@ -123,7 +140,7 @@ yamlConfigDirectory :: FilePath -> MaybeT IO FilePath yamlConfigDirectory = findFileUpwards (configFileName ==) -readCradleConfig :: FilePath -> IO CradleConfig+readCradleConfig :: Yaml.FromJSON b => FilePath -> IO (CradleConfig b) readCradleConfig yamlHie = do   cfg  <- liftIO $ readConfig yamlHie   return (cradle cfg)@@ -133,14 +150,56 @@  --------------------------------------------------------------- +isCabalCradle :: Cradle a -> Bool+isCabalCradle crdl = case actionName (cradleOptsProg crdl) of+  Types.Cabal -> True+  _ -> False++isStackCradle :: Cradle a -> Bool+isStackCradle crdl = case actionName (cradleOptsProg crdl) of+  Types.Stack -> True+  _ -> False++isDirectCradle :: Cradle a -> Bool+isDirectCradle crdl = case actionName (cradleOptsProg crdl) of+  Types.Direct -> True+  _ -> False++isBiosCradle :: Cradle a -> Bool+isBiosCradle crdl = case actionName (cradleOptsProg crdl) of+  Types.Bios -> True+  _ -> False++isMultiCradle :: Cradle a -> Bool+isMultiCradle crdl = case actionName (cradleOptsProg crdl) of+  Types.Multi -> True+  _ -> False++isNoneCradle :: Cradle a -> Bool+isNoneCradle crdl = case actionName (cradleOptsProg crdl) of+  Types.None -> True+  _ -> False++isDefaultCradle :: Cradle a -> Bool+isDefaultCradle crdl = case actionName (cradleOptsProg crdl) of+  Types.Default -> True+  _ -> False++isOtherCradle :: Cradle a -> Bool+isOtherCradle crdl = case actionName (cradleOptsProg crdl) of+  Types.Other _ -> True+  _ -> False++---------------------------------------------------------------+ -- | Default cradle has no special options, not very useful for loading -- modules.-defaultCradle :: FilePath -> Cradle+defaultCradle :: FilePath -> Cradle a defaultCradle cur_dir =   Cradle     { cradleRootDir = cur_dir     , cradleOptsProg = CradleAction-        { actionName = "default"+        { actionName = Types.Default         , runCradle = \_ _ -> return (CradleSuccess (ComponentOptions [] []))         }     }@@ -148,12 +207,12 @@ --------------------------------------------------------------- -- The none cradle tells us not to even attempt to load a certain directory -noneCradle :: FilePath -> Cradle+noneCradle :: FilePath -> Cradle a noneCradle cur_dir =   Cradle     { cradleRootDir = cur_dir     , cradleOptsProg = CradleAction-        { actionName = "none"+        { actionName = Types.None         , runCradle = \_ _ -> return CradleNone         }     }@@ -161,34 +220,61 @@ --------------------------------------------------------------- -- The multi cradle selects a cradle based on the filepath -multiCradle :: FilePath -> [(FilePath, CradleConfig)] -> Cradle-multiCradle cur_dir cs =+multiCradle :: (b -> Cradle a) -> FilePath -> [(FilePath, CradleConfig b)] -> Cradle a+multiCradle buildCustomCradle cur_dir cs =   Cradle-    { cradleRootDir = cur_dir+    { cradleRootDir  = cur_dir     , cradleOptsProg = CradleAction-        { actionName = "multi"-        , runCradle = \l fp -> canonicalizePath fp >>= multiAction cur_dir cs l+        { actionName = multiActionName+        , runCradle  = \l fp -> canonicalizePath fp >>= multiAction buildCustomCradle cur_dir cs l         }     }+  where+    cfgs = map snd cs -multiAction :: FilePath-            -> [(FilePath, CradleConfig)]+    multiActionName+      | all (\c -> isStackCradleConfig c || isNoneCradleConfig c) cfgs+      = Types.Stack+      | all (\c -> isCabalCradleConfig c || isNoneCradleConfig c) cfgs+      = Types.Cabal+      | otherwise+      = Types.Multi++    isStackCradleConfig cfg = case cradleType cfg of+      Stack{}      -> True+      StackMulti{} -> True+      _            -> False++    isCabalCradleConfig cfg = case cradleType cfg of+      Cabal{}      -> True+      CabalMulti{} -> True+      _            -> False++    isNoneCradleConfig cfg = case cradleType cfg of+      None -> True+      _    -> False++multiAction ::  forall b a+            . (b -> Cradle a)+            -> FilePath+            -> [(FilePath, CradleConfig b)]             -> LoggingFunction             -> FilePath             -> IO (CradleLoadResult ComponentOptions)-multiAction cur_dir cs l cur_fp = selectCradle =<< canonicalizeCradles+multiAction buildCustomCradle cur_dir cs l cur_fp =+    selectCradle =<< canonicalizeCradles    where     err_msg = ["Multi Cradle: No prefixes matched"-                      , "pwd: " ++ cur_dir-                      , "filepath" ++ cur_fp-                      , "prefixes:"-                      ] ++ [show (pf, cradleType cc) | (pf, cc) <- cs]+              , "pwd: " ++ cur_dir+              , "filepath: " ++ cur_fp+              , "prefixes:"+              ] ++ [show (pf, cradleType cc) | (pf, cc) <- cs]      -- Canonicalize the relative paths present in the multi-cradle and     -- also order the paths by most specific first. In the cradle selection     -- function we want to choose the most specific cradle possible.-    canonicalizeCradles :: IO [(FilePath, CradleConfig)]+    canonicalizeCradles :: IO [(FilePath, CradleConfig b)]     canonicalizeCradles =       sortOn (Down . fst)         <$> mapM (\(p, c) -> (,c) <$> (canonicalizePath (cur_dir </> p))) cs@@ -197,18 +283,21 @@       return (CradleFail (CradleError ExitSuccess err_msg))     selectCradle ((p, c): css) =         if p `isPrefixOf` cur_fp-          then runCradle (cradleOptsProg (getCradle (c, cur_dir))) l cur_fp+          then runCradle+                  (cradleOptsProg (getCradle buildCustomCradle (c, cur_dir)))+                  l+                  cur_fp           else selectCradle css   ------------------------------------------------------------------------- -directCradle :: FilePath -> [String] -> Cradle+directCradle :: FilePath -> [String] -> Cradle a directCradle wdir args  =   Cradle     { cradleRootDir = wdir     , cradleOptsProg = CradleAction-        { actionName = "direct"+        { actionName = Types.Direct         , runCradle = \_ _ -> return (CradleSuccess (ComponentOptions args []))         }     }@@ -218,12 +307,12 @@  -- | Find a cradle by finding an executable `hie-bios` file which will -- be executed to find the correct GHC options to use.-biosCradle :: FilePath -> FilePath -> Maybe FilePath -> Cradle+biosCradle :: FilePath -> FilePath -> Maybe FilePath -> Cradle a biosCradle wdir biosProg biosDepsProg =   Cradle     { cradleRootDir    = wdir     , cradleOptsProg   = CradleAction-        { actionName = "bios"+        { actionName = Types.Bios         , runCradle = biosAction wdir biosProg biosDepsProg         }     }@@ -260,13 +349,12 @@ -- Cabal Cradle -- Works for new-build by invoking `v2-repl` does not support components -- yet.--cabalCradle :: FilePath -> Maybe String -> Cradle+cabalCradle :: FilePath -> Maybe String -> Cradle a cabalCradle wdir mc =   Cradle     { cradleRootDir    = wdir     , cradleOptsProg   = CradleAction-        { actionName = "cabal"+        { actionName = Types.Cabal         , runCradle = cabalAction wdir mc         }     }@@ -288,6 +376,7 @@         (dir: ghc_args) ->             let final_args =                     removeVerbosityOpts+                    $ removeRTS                     $ removeInteractive                     $ map (fixImportDirs dir)                     $ ghc_args@@ -307,16 +396,17 @@   wrapper_fp <-     if isWindows       then do-        cacheDir <- getXdgDirectory XdgCache "hie-bios"-        let wrapper_name = "wrapper-" ++ showVersion version+        cacheDir <- getCacheDir ""+        let srcHash = show (fingerprintString cabalWrapperHs)+        let wrapper_name = "wrapper-" ++ srcHash         let wrapper_fp = cacheDir </> wrapper_name <.> "exe"         exists <- doesFileExist wrapper_fp-        unless exists $ do-            tempDir <- getTemporaryDirectory-            let wrapper_hs = tempDir </> wrapper_name <.> "hs"-            writeFile wrapper_hs cabalWrapperHs+        unless exists $ withSystemTempDirectory "hie-bios" $ \ tmpDir -> do             createDirectoryIfMissing True cacheDir-            let ghc = (proc ghcPath $ ghcArgs ++ ["-o", wrapper_fp, wrapper_hs])+            let wrapper_hs = cacheDir </> wrapper_name <.> "hs"+            writeFile wrapper_hs cabalWrapperHs+            let ghc = (proc ghcPath $+                        ghcArgs ++ ["-rtsopts=ignore", "-outputdir", tmpDir, "-o", wrapper_fp, wrapper_hs])                         { cwd = Just wdir }             readCreateProcess ghc "" >>= putStr         return wrapper_fp@@ -327,10 +417,9 @@   return wrapper_fp  cabalAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)-cabalAction work_dir mc l _fp = do+cabalAction work_dir mc l fp = do   wrapper_fp <- getCabalWrapperTool ("ghc", []) work_dir-  let cab_args = ["v2-repl", "--with-compiler", wrapper_fp]-                  ++ [component_name | Just component_name <- [mc]]+  let cab_args = ["v2-repl", "--with-compiler", wrapper_fp, fromMaybe (fixTargetPath fp) mc]   (ex, output, stde, args) <-     readProcessWithOutputFile l Nothing work_dir "cabal" cab_args   deps <- cabalCradleDependencies work_dir@@ -341,10 +430,25 @@                    , unlines stde                    , unlines args])       Just final_args -> pure $ makeCradleResult (ex, stde, final_args) deps+  where+    -- Need to make relative on Windows, due to a Cabal bug with how it+    -- parses file targets with a C: drive in it+    fixTargetPath x+      | isWindows && hasDrive x = makeRelative work_dir x+      | otherwise = x  removeInteractive :: [String] -> [String] removeInteractive = filter (/= "--interactive") +-- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.+removeRTS :: [String] -> [String]+removeRTS ("+RTS" : xs)  =+  case dropWhile (/= "-RTS") xs of+    [] -> []+    (_ : ys) -> removeRTS ys+removeRTS (y:ys)         = y : removeRTS ys+removeRTS []             = []+ removeVerbosityOpts :: [String] -> [String] removeVerbosityOpts = filter ((&&) <$> (/= "-v0") <*> (/= "-w")) @@ -366,12 +470,12 @@ -- Stack Cradle -- Works for by invoking `stack repl` with a wrapper script -stackCradle :: FilePath -> Maybe String -> Cradle+stackCradle :: FilePath -> Maybe String -> Cradle a stackCradle wdir mc =   Cradle     { cradleRootDir    = wdir     , cradleOptsProg   = CradleAction-        { actionName = "stack"+        { actionName = Types.Stack         , runCradle = stackAction wdir mc         }     }@@ -389,7 +493,8 @@    (ex1, _stdo, stde, args) <-     readProcessWithOutputFile l Nothing work_dir-            "stack" $ ["repl", "--no-nix-pure", "--with-ghc", wrapper_fp] ++ maybeToList mc+            "stack" $ ["repl", "--no-nix-pure", "--with-ghc", wrapper_fp]+                      ++ [ comp | Just comp <- [mc] ]   (ex2, pkg_args, stdr, _) <-     readProcessWithOutputFile l Nothing work_dir "stack" ["path", "--ghc-package-path"]   let split_pkgs = concatMap splitSearchPath pkg_args@@ -500,13 +605,19 @@ -- the predicate. findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath findFileUpwards p dir = do-    cnts <- liftIO $ findFile p dir-    case cnts of-        [] | dir' == dir -> fail "No cabal files"-           | otherwise   -> findFileUpwards p dir'-        _:_          -> return dir-  where-    dir' = takeDirectory dir+  cnts <-+    liftIO+    $ handleJust+        -- Catch permission errors+        (\(e :: IOError) -> if isPermissionError e then Just [] else Nothing)+        pure+        (findFile p dir)++  case cnts of+    [] | dir' == dir -> fail "No cabal files"+            | otherwise   -> findFileUpwards p dir'+    _ : _ -> return dir+  where dir' = takeDirectory dir  -- | Sees if any file in the directory matches the predicate findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]

@@ -1,5 +1,5 @@ {-# LANGUAGE RecordWildCards, CPP #-}-module HIE.Bios.Environment (initSession, getSystemLibDir, addCmdOpts) where+module HIE.Bios.Environment (initSession, getSystemLibDir, getCacheDir, addCmdOpts) where  import CoreMonad (liftIO) import GHC (DynFlags(..), GhcLink(..), HscTarget(..), GhcMonad)@@ -13,6 +13,7 @@ import System.Process (readProcess) import System.Directory import System.FilePath+import System.Environment (lookupEnv)  import qualified Crypto.Hash.SHA1 as H import qualified Data.ByteString.Char8 as B@@ -75,8 +76,16 @@ >   res <- doesPathExist cd >   when res (removeDirectoryRecursive cd) -}++-- | Prepends the cache directory used by the library to the supplied file path.+-- It tries to use the path under the environment variable `$HIE_BIOS_CACHE_DIR` +-- and falls back to the standard `$XDG_CACHE_HOME/hie-bios` if the former is not set getCacheDir :: FilePath -> IO FilePath-getCacheDir fp = getXdgDirectory XdgCache (cacheDir </> fp)+getCacheDir fp = do+  mbEnvCacheDirectory <- lookupEnv "HIE_BIOS_CACHE_DIR"+  cacheBaseDir <- maybe (getXdgDirectory XdgCache cacheDir) return+                         mbEnvCacheDirectory+  return (cacheBaseDir </> fp)  ---------------------------------------------------------------- 

@@ -8,7 +8,7 @@ -- file or GHC session according to the provided 'Cradle'. getCompilerOptions ::     FilePath -- The file we are loading it because of-    -> Cradle+    -> Cradle a     -> IO (CradleLoadResult ComponentOptions) getCompilerOptions fp cradle =   runCradle (cradleOptsProg cradle) logm fp

@@ -62,8 +62,8 @@ initializeFlagsWithCradle ::     GhcMonad m     => FilePath -- ^ The file we are loading the 'Cradle' because of-    -> Cradle   -- ^ The cradle we want to load-    -> m (CradleLoadResult (m G.SuccessFlag))+    -> Cradle a   -- ^ The cradle we want to load+    -> m (CradleLoadResult (m G.SuccessFlag, ComponentOptions)) initializeFlagsWithCradle = initializeFlagsWithCradleWithMessage (Just G.batchMsg)  -- | The same as 'initializeFlagsWithCradle' but with an additional argument to control@@ -73,10 +73,10 @@   GhcMonad m   => Maybe G.Messager   -> FilePath -- ^ The file we are loading the 'Cradle' because of-  -> Cradle   -- ^ The cradle we want to load-  -> m (CradleLoadResult (m G.SuccessFlag)) -- ^ Whether we actually loaded the cradle or not.+  -> Cradle a  -- ^ The cradle we want to load+  -> m (CradleLoadResult (m G.SuccessFlag, ComponentOptions)) -- ^ Whether we actually loaded the cradle or not. initializeFlagsWithCradleWithMessage msg fp cradle =-    fmap (initSessionWithMessage msg) <$> (liftIO $ getCompilerOptions fp cradle)+    fmap (initSessionWithMessage msg) <$> liftIO (getCompilerOptions fp cradle)  -- | Actually perform the initialisation of the session. Initialising the session corresponds to -- parsing the command line flags, setting the targets for the session and then attempting to load@@ -84,13 +84,13 @@ initSessionWithMessage :: (GhcMonad m)             => Maybe G.Messager             -> ComponentOptions-            -> m G.SuccessFlag-initSessionWithMessage msg compOpts = do+            -> (m G.SuccessFlag, ComponentOptions)+initSessionWithMessage msg compOpts = (do     targets <- initSession compOpts     G.setTargets targets     -- Get the module graph using the function `getModuleGraph`     mod_graph <- G.depanal [] True-    G.load' LoadAllTargets msg mod_graph+    G.load' LoadAllTargets msg mod_graph, compOpts)  ---------------------------------------------------------------- 

@@ -23,7 +23,8 @@  -- | Checking syntax of a target file using GHC. --   Warnings and errors are returned.-checkSyntax :: Cradle+checkSyntax :: Show a+            => Cradle a             -> [FilePath]  -- ^ The target files.             -> IO String checkSyntax _      []    = return ""@@ -31,7 +32,7 @@     Log.debugm $ "Cradle: " ++ show cradle     res <- initializeFlagsWithCradle (head files) cradle     case res of-      CradleSuccess ini -> do+      CradleSuccess (ini, _) -> do         _sf <- ini         either id id <$> check files       CradleFail ce -> liftIO $ throwIO ce

@@ -22,7 +22,6 @@  import DynFlags (DynFlags) import GHC(LHsBind, LHsExpr, LPat, Type, ModSummary, ModuleGraph, HscEnv, setLogAction, GhcMonad)-import HsExpr (MatchGroup) import Outputable (PrintUnqualified, PprStyle, Depth(AllTheWay), mkUserStyle)  #if __GLASGOW_HASKELL__ >= 808@@ -37,47 +36,39 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 802-#else-import GHC.PackageDb (ExposedModule(..))-#endif- #if __GLASGOW_HASKELL__ >= 804 import DynFlags (WarningFlag) import qualified EnumSet as E (EnumSet, empty) import GHC (mgModSummaries, mapMG)-#else-import qualified Data.IntSet as I (IntSet, empty) #endif -#if __GLASGOW_HASKELL__ >= 806-import HsExpr (MatchGroupTc(..))+#if __GLASGOW_HASKELL__ >= 810+import GHC.Hs.Extension (GhcTc)+import GHC.Hs.Expr (MatchGroup, MatchGroupTc(..), mg_ext)+#elif __GLASGOW_HASKELL__ >= 806 import HsExtension (GhcTc)+import HsExpr (MatchGroup, MatchGroupTc(..)) import GHC (mg_ext) #elif __GLASGOW_HASKELL__ >= 804 import HsExtension (GhcTc)+import HsExpr (MatchGroup) import GHC (mg_res_ty, mg_arg_tys) #else-import GHC (Id, mg_res_ty, mg_arg_tys)+import HsExtension (GhcTc)+import HsExpr (MatchGroup) #endif - ---------------------------------------------------------------- ----------------------------------------------------------------  makeUserStyle :: DynFlags -> PrintUnqualified -> PprStyle-#if __GLASGOW_HASKELL__ >= 802+#if __GLASGOW_HASKELL__ >= 804 makeUserStyle dflags style = mkUserStyle dflags style AllTheWay-#else-makeUserStyle _      style = mkUserStyle        style AllTheWay #endif -#if __GLASGOW_HASKELL__ >= 802+#if __GLASGOW_HASKELL__ >= 804 getModuleName :: (a, b) -> a getModuleName = fst-#else-getModuleName :: ExposedModule unitid modulename -> modulename-getModuleName = exposedName #endif  ----------------------------------------------------------------@@ -86,10 +77,6 @@ type WarnFlags = E.EnumSet WarningFlag emptyWarnFlags :: WarnFlags emptyWarnFlags = E.empty-#else-type WarnFlags = I.IntSet-emptyWarnFlags :: WarnFlags-emptyWarnFlags = I.empty #endif  #if __GLASGOW_HASKELL__ >= 804@@ -101,15 +88,6 @@  fixInfo :: (a, b, c, d, e) -> (a, b, c, d) fixInfo (t,f,cs,fs,_) = (t,f,cs,fs)-#else-getModSummaries :: a -> a-getModSummaries = id--getTyThing :: (a, b, c, d) -> a-getTyThing (t,_,_,_) = t--fixInfo :: (a, b, c, d) -> (a, b, c, d)-fixInfo = id #endif  ----------------------------------------------------------------@@ -132,27 +110,6 @@ inTypes = mg_arg_tys outType :: MatchGroup GhcTc LExpression -> Type outType = mg_res_ty-#else-type LExpression = LHsExpr Id-type LBinding    = LHsBind Id-type LPattern    = LPat    Id--inTypes :: MatchGroup Id LExpression -> [Type]-inTypes = mg_arg_tys-outType :: MatchGroup Id LExpression -> Type-outType = mg_res_ty-#endif--#if __GLASGOW_HASKELL__ >= 804-#else-mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph-mapMG = map-#endif--#if __GLASGOW_HASKELL__ >= 804-#else-mgModSummaries :: ModuleGraph -> [ModSummary]-mgModSummaries = id #endif  numLoadedPlugins :: DynFlags -> Int

@@ -1,14 +1,20 @@-module HIE.Bios.Internal.Debug (debugInfo, rootInfo) where+{-# LANGUAGE LambdaCase #-}+module HIE.Bios.Internal.Debug (debugInfo, rootInfo, configInfo, cradleInfo) where  import Control.Monad.IO.Class (liftIO)+import Control.Monad+import Data.Void  import qualified Data.Char as Char import Data.Maybe (fromMaybe)  import HIE.Bios.Ghc.Api+import HIE.Bios.Cradle import HIE.Bios.Types import HIE.Bios.Flags +import System.Directory+ ----------------------------------------------------------------  -- | Obtain debug information for a 'Cradle'.@@ -19,11 +25,15 @@ -- the file dependencies and so on. -- -- Otherwise, shows the error message and exit-code.-debugInfo :: FilePath-          -> Cradle+debugInfo :: Show a+          => FilePath+          -> Cradle a           -> IO String debugInfo fp cradle = unlines <$> do     res <- getCompilerOptions fp cradle+    canonFp <- canonicalizePath fp+    conf <- findConfig canonFp+    crdl <- findCradle' canonFp     case res of       CradleSuccess (ComponentOptions gopts deps) -> do         mglibdir <- liftIO getSystemLibDir@@ -31,6 +41,8 @@             "Root directory:      " ++ rootDir           , "GHC options:         " ++ unwords (map quoteIfNeeded gopts)           , "System libraries:    " ++ fromMaybe "" mglibdir+          , "Config Location:     " ++ conf+          , "Cradle:              " ++ crdl           , "Dependencies:        " ++ unwords deps           ]       CradleFail (CradleError ext stderr) ->@@ -48,6 +60,39 @@ ----------------------------------------------------------------  -- | Get the root directory of the given Cradle.-rootInfo :: Cradle+rootInfo :: Cradle a           -> IO String rootInfo cradle = return $ cradleRootDir cradle++----------------------------------------------------------------++configInfo :: [FilePath] -> IO String+configInfo []   = return "No files given"+configInfo args =+  fmap unlines $ forM args $ \fp -> do+    fp' <- canonicalizePath fp+    (("Config for \"" ++ fp' ++ "\": ") ++) <$> findConfig fp'++findConfig :: FilePath -> IO String+findConfig fp = findCradle fp >>= \case+  Just yaml -> return yaml+  _ -> return "No explicit config found"++----------------------------------------------------------------++cradleInfo :: [FilePath] -> IO String+cradleInfo [] = return "No files given"+cradleInfo args =+  fmap unlines $ forM args $ \fp -> do+    fp' <- canonicalizePath fp+    (("Cradle for \"" ++ fp' ++ "\": ") ++)  <$> findCradle' fp'++findCradle' :: FilePath -> IO String+findCradle' fp =+  findCradle fp >>= \case+    Just yaml -> do+      crdl <- loadCradle yaml+      return $ show crdl+    Nothing -> do+      crdl <- loadImplicitCradle fp :: IO (Cradle Void)+      return $ show crdl

@@ -31,33 +31,46 @@ -- -- A 'Cradle' may be a single unit in the \"cabal-install\" context, or -- the whole package, comparable to how \"stack\" works.-data Cradle = Cradle {+data Cradle a = Cradle {   -- | The project root directory.     cradleRootDir    :: FilePath   -- | The action which needs to be executed to get the correct   -- command line arguments.-  , cradleOptsProg   :: CradleAction-  } deriving (Show)+  , cradleOptsProg   :: CradleAction a+  } deriving (Show, Functor)  type LoggingFunction = String -> IO () -data CradleAction = CradleAction {-                      actionName :: String+data ActionName a+  = Stack+  | Cabal+  | Bios+  | Default+  | Multi+  | Direct+  | None+  | Other a+  deriving (Show, Eq, Ord, Functor)++data CradleAction a = CradleAction {+                      actionName :: ActionName a                       -- ^ Name of the action.                       , runCradle :: LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)                       -- ^ Options to compile the given file with.                       }+  deriving (Functor) -instance Show CradleAction where-  show CradleAction { actionName = name } = "CradleAction: " ++ name+instance Show a => Show (CradleAction a) where+  show CradleAction { actionName = name } = "CradleAction: " ++ show name  -- | Result of an attempt to set up a GHC session for a 'Cradle'. -- This is the go-to error handling mechanism. When possible, this -- should be preferred over throwing exceptions.-data CradleLoadResult r = CradleSuccess r -- ^ The cradle succeeded and returned these options.-                      | CradleFail CradleError -- ^ We tried to load the cradle and it failed.-                      | CradleNone -- ^ No attempt was made to load the cradle.-                      deriving (Functor)+data CradleLoadResult r+  = CradleSuccess r -- ^ The cradle succeeded and returned these options.+  | CradleFail CradleError -- ^ We tried to load the cradle and it failed.+  | CradleNone -- ^ No attempt was made to load the cradle.+  deriving (Functor, Show)   data CradleError = CradleError ExitCode [String] deriving (Show)@@ -78,4 +91,4 @@   -- This is useful, because, sometimes, adding specific files   -- changes the options that a Cradle may return, thus, needs reload   -- as soon as these files are created.-  } deriving (Eq, Show)+  } deriving (Eq, Ord, Show)

@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} module Main where @@ -6,10 +7,14 @@ import HIE.Bios import HIE.Bios.Ghc.Api import HIE.Bios.Ghc.Load+import HIE.Bios.Cradle+import HIE.Bios.Types import Control.Monad.IO.Class-import Control.Monad ( unless, forM_ )+import Control.Monad ( unless, forM_, when )+import Data.Void import System.Directory import System.FilePath ( makeRelative, (</>) )+import System.Info.Extra ( isWindows )  main :: IO () main = do@@ -31,38 +36,56 @@                   (Just "./tests/projects/simple-cabal/hie.yaml")                 )         ]-      , testGroup "Loading tests" [-        testCaseSteps "simple-cabal" $ testDirectory "./tests/projects/simple-cabal/B.hs"-        , testCaseSteps "simple-stack" $ testDirectory "./tests/projects/simple-stack/B.hs"-        , testCaseSteps "simple-direct" $ testDirectory "./tests/projects/simple-direct/B.hs"-        , testCaseSteps "simple-bios" $ testDirectory "./tests/projects/simple-bios/B.hs"-        , testCaseSteps "multi-cabal" {- tests if both components can be loaded -}-                      $  testDirectory "./tests/projects/multi-cabal/app/Main.hs"-                      >> testDirectory "./tests/projects/multi-cabal/src/Lib.hs"-        , testCaseSteps "multi-stack" {- tests if both components can be loaded -}-                      $  testDirectory "./tests/projects/multi-stack/app/Main.hs"-                      >> testDirectory "./tests/projects/multi-stack/src/Lib.hs"+      , testGroup "Loading tests"+        $ linuxExlusiveTestCases+        +++           [ testCaseSteps "simple-cabal" $ testDirectory isCabalCradle "./tests/projects/simple-cabal/B.hs"+           , testCaseSteps "simple-stack" $ testDirectory isStackCradle "./tests/projects/simple-stack/B.hs"+           , testCaseSteps "simple-direct" $ testDirectory isDirectCradle "./tests/projects/simple-direct/B.hs"+           , testCaseSteps "multi-direct" {- tests if both components can be loaded -}+                         $  testDirectory isMultiCradle "./tests/projects/multi-direct/A.hs"+                         >> testDirectory isMultiCradle "./tests/projects/multi-direct/B.hs"+           , testCaseSteps "multi-cabal" {- tests if both components can be loaded -}+                         $  testDirectory isCabalCradle "./tests/projects/multi-cabal/app/Main.hs"+                         >> testDirectory isCabalCradle "./tests/projects/multi-cabal/src/Lib.hs"+           , testCaseSteps "multi-stack" {- tests if both components can be loaded -}+                         $  testDirectory isStackCradle "./tests/projects/multi-stack/app/Main.hs"+                         >> testDirectory isStackCradle "./tests/projects/multi-stack/src/Lib.hs"+           ]+      , testGroup "Implicit cradle tests" $+        [ testCaseSteps "implicit-cabal" $ testImplicitCradle "./tests/projects/implicit-cabal/Main.hs" Cabal+        , testCaseSteps "implicit-stack" $ testImplicitCradle "./tests/projects/implicit-stack/Main.hs" Stack+        , testCaseSteps "implicit-stack-multi"+            $ testImplicitCradle "./tests/projects/implicit-stack-multi/Main.hs" Stack+            >> testImplicitCradle "./tests/projects/implicit-stack-multi/other-package/Main.hs" Stack         ]       ] -+linuxExlusiveTestCases :: [TestTree]+linuxExlusiveTestCases = [ testCaseSteps "simple-bios" $ testDirectory isBiosCradle "./tests/projects/simple-bios/B.hs" | not isWindows ] -testDirectory :: FilePath -> (String -> IO ()) -> IO ()-testDirectory fp step = do+testDirectory :: (Cradle Void -> Bool) -> FilePath -> (String -> IO ()) -> IO ()+testDirectory cradlePred fp step = do   a_fp <- canonicalizePath fp-  step "Finding Cradle"+  step $ "Finding Cradle for: " ++ a_fp   mcfg <- findCradle a_fp-  step "Loading Cradle"+  step $ "Loading Cradle: " ++ show mcfg   crd <- case mcfg of           Just cfg -> loadCradle cfg           Nothing -> loadImplicitCradle a_fp+  when (not $ cradlePred crd) $ error $ "Cradle is incorrect: " ++ show (actionName $ cradleOptsProg crd)   step "Initialise Flags"+  testLoadFile crd a_fp step++testLoadFile :: Cradle a -> FilePath -> (String -> IO ()) -> IO ()+testLoadFile crd fp step = do+  a_fp <- canonicalizePath fp   withCurrentDirectory (cradleRootDir crd) $     withGHC' $ do       let relFp = makeRelative (cradleRootDir crd) a_fp       res <- initializeFlagsWithCradleWithMessage (Just (\_ n _ _ -> step (show n))) relFp crd       case res of-        CradleSuccess ini -> do+        CradleSuccess (ini, _) -> do           liftIO (step "Initial module load")           sf <- ini           case sf of@@ -85,6 +108,16 @@     ++ ", Actual: "     ++ show mcfg +testImplicitCradle :: FilePath -> ActionName Void -> (String -> IO ()) -> IO ()+testImplicitCradle fp' expectedActionName step = do+  fp <- canonicalizePath fp'+  step "Inferring implicit cradle"+  crd <- loadImplicitCradle fp :: IO (Cradle Void)+  unless (actionName (cradleOptsProg crd) == expectedActionName)+    $ error $ "Expected cradle: " <> show expectedActionName+    <> "\n, Actual: " <> show (actionName (cradleOptsProg crd))+  step "Initialize flags"+  testLoadFile crd fp step  writeStackYamlFiles :: IO () writeStackYamlFiles = do@@ -96,6 +129,8 @@ stackProjects =   [ "tests" </> "projects" </> "multi-stack"   , "tests" </> "projects" </> "simple-stack"+  , "tests" </> "projects" </> "implicit-stack"+  , "tests" </> "projects" </> "implicit-stack-multi"   ]  stackYaml :: String -> String

@@ -1,9 +1,15 @@+{-# LANGUAGE OverloadedStrings #-} module Main where  import Test.Tasty import Test.Tasty.HUnit import HIE.Bios.Config+import qualified Data.HashMap.Strict as Map+import Data.Void+import Data.Yaml+import qualified Data.Text as T import System.FilePath+import Control.Applicative ( (<|>) )  configDir :: FilePath configDir = "tests/configs"@@ -39,12 +45,61 @@                                                                     StackMulti [("./src", "lib:hie-bios")                                                                               ,("./tests", "parser-tests")]))])) -assertParser :: FilePath -> Config -> Assertion+    assertCustomParser "ch-cabal.yaml"+      (noDeps (Other CabalHelperCabal $ simpleCabalHelperYaml "cabal"))+    assertCustomParser "ch-stack.yaml"+      (noDeps (Other CabalHelperStack $ simpleCabalHelperYaml "stack"))+    assertCustomParser "multi-ch.yaml"+      (noDeps (Multi+        [ ("./src", CradleConfig [] (Other CabalHelperStack $ simpleCabalHelperYaml "stack"))+        , ("./input", CradleConfig [] (Other CabalHelperCabal $ simpleCabalHelperYaml "cabal"))+        , ("./test", CradleConfig [] (Cabal (Just "test")))+        , (".", CradleConfig [] None)+        ]))++assertParser :: FilePath -> Config Void -> Assertion assertParser fp cc = do   conf <- readConfig (configDir </> fp)   (conf == cc) @? (unlines [("Parser Failed: " ++ fp)                            , "Expected: " ++ show cc                            , "Actual: " ++ show conf ]) -noDeps :: CradleType -> Config+assertCustomParser :: FilePath -> Config CabalHelper -> Assertion+assertCustomParser fp cc = do+  conf <- readConfig (configDir </> fp)+  (conf == cc) @? (unlines [("Parser Failed: " ++ fp)+                          , "Expected: " ++ show cc+                          , "Actual: " ++ show conf ])++noDeps :: CradleType a -> Config a noDeps c = Config (CradleConfig [] c)++-- ------------------------------------------------------------------++data CabalHelper+  = CabalHelperCabal+  | CabalHelperStack+  deriving (Show, Eq)++instance FromJSON CabalHelper where+  parseJSON (Object o)+    | Just obj <- Map.lookup "cabal-helper" o = chCabal obj <|> chStack obj+    where+      chCabal (Object val)+        | Just _val <- Map.lookup "cabal" val = return CabalHelperCabal+      chCabal _ = fail "CH: not a cabal cradle."++      chStack (Object val)+        | Just _val <- Map.lookup "stack" val = return CabalHelperStack+      chStack _ = fail "CH: not a stack cradle."++  parseJSON _ = fail "Not a valid cabal-helper specification"++simpleCabalHelperYaml :: T.Text -> Value+simpleCabalHelperYaml tool =+  object+    [ ( "cabal-helper", object+        [ (tool, Null)+        ]+      )+    ]

@@ -0,0 +1,4 @@+cradle:+  other:+    cabal-helper:+      cabal:

@@ -0,0 +1,4 @@+cradle:+  other:+    cabal-helper:+      stack:

@@ -0,0 +1,10 @@+cradle:+  multi:+    - path: "./src"+      config: { cradle: {other: {cabal-helper: {stack: } } } }+    - path: "./input"+      config: { cradle: {other: {cabal-helper: {cabal: } } } }+    - path: "./test"+      config: { cradle: {cabal: {component: "test"}} }+    - path: "."+      config: { cradle: { none: } }

@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = putStrLn "Hello, Haskell!"

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,1 @@+packages: .

@@ -0,0 +1,25 @@+cabal-version:       >=1.10+-- Initial package description 'implicit-cabal.cabal' generated by 'cabal+-- init'.  For further documentation, see+-- http://haskell.org/cabal/users-guide/++name:                implicit-cabal+version:             0.1.0.0+-- synopsis:+-- description:+-- bug-reports:+-- license:+license-file:        LICENSE+author:              Luke Lau+maintainer:          luke_lau@icloud.com+-- copyright:+-- category:+build-type:          Simple++executable implicit-cabal+  main-is:             Main.hs+  -- other-modules:+  -- other-extensions:+  build-depends:       base == 4.*+  -- hs-source-dirs:+  default-language:    Haskell2010

@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = putStrLn "Hello, Haskell!"

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,25 @@+cabal-version:       >=1.10+-- Initial package description 'implicit-stack-multi.cabal' generated by+-- 'cabal init'.  For further documentation, see+-- http://haskell.org/cabal/users-guide/++name:                implicit-stack-multi+version:             0.1.0.0+-- synopsis:+-- description:+-- bug-reports:+-- license:+license-file:        LICENSE+author:              Luke Lau+maintainer:          luke_lau@icloud.com+-- copyright:+-- category:+build-type:          Simple++executable implicit-stack-multi+  main-is:             Main.hs+  -- other-modules:+  -- other-extensions:+  build-depends:       base == 4.*+  -- hs-source-dirs:+  default-language:    Haskell2010

@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = putStrLn "Hello, Haskell!"

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,26 @@+cabal-version:       >=1.10+-- Initial package description 'other-package.cabal' generated by 'cabal+-- init'.  For further documentation, see+-- http://haskell.org/cabal/users-guide/++name:                other-package+version:             0.1.0.0+-- synopsis:+-- description:+-- bug-reports:+-- license:+license-file:        LICENSE+author:              Luke Lau+maintainer:          luke_lau@icloud.com+-- copyright:+-- category:+build-type:          Simple+extra-source-files:  CHANGELOG.md++executable other-package+  main-is:             Main.hs+  -- other-modules:+  -- other-extensions:+  build-depends:       base == 4.*+  -- hs-source-dirs:+  default-language:    Haskell2010

@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = putStrLn "Hello, Haskell!"

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,25 @@+cabal-version:       >=1.10+-- Initial package description 'implicit-stack.cabal' generated by 'cabal+-- init'.  For further documentation, see+-- http://haskell.org/cabal/users-guide/++name:                implicit-stack+version:             0.1.0.0+-- synopsis:+-- description:+-- bug-reports:+-- license:+license-file:        LICENSE+author:              Luke Lau+maintainer:          luke_lau@icloud.com+-- copyright:+-- category:+build-type:          Simple++executable implicit-stack+  main-is:             Main.hs+  -- other-modules:+  -- other-extensions:+  build-depends:       base == 4.*+  -- hs-source-dirs:+  default-language:    Haskell2010

@@ -10,6 +10,7 @@   build-depends:       base >=4.10 && < 5, filepath   hs-source-dirs:      src   default-language:    Haskell2010+  ghc-options:         +RTS -A1m -N -RTS -Wall   

@@ -0,0 +1,1 @@+module A where

@@ -0,0 +1,3 @@+module B where++import A

@@ -0,0 +1,12 @@+cradle:+  multi:+    - path: "A.hs"+      config:+        cradle:+          direct:+            arguments: ["-Walaaal", "A", "B"]+    - path: "B.hs"+      config:+        cradle:+          direct:+            arguments: ["-Walaaal", "A", "B"]

@@ -20,3 +20,4 @@   build-depends:       base >=4.10 && < 5, directory   -- hs-source-dirs:   default-language:    Haskell2010+  ghc-options:         +RTS -A1m -N -RTS -Wall

@@ -18,5 +18,6 @@   -- other-modules:   -- other-extensions:   build-depends:       base >=4.10 && < 5+  ghc-options:         +RTS -A1m -N -RTS -Wall   -- hs-source-dirs:   default-language:    Haskell2010

@@ -18,5 +18,6 @@   -- other-modules:   -- other-extensions:   build-depends:       base >=4.10 && < 5+  ghc-options:         -Wall +RTS -A1m -N -RTS   -- hs-source-dirs:   default-language:    Haskell2010