Fix issue 20.

src/Development/BuildSystem.hs

@@ -3,18 +3,23 @@ module Development.BuildSystem
   , mkExecArgs
   , buildSystems
   , checkTillRoot
+  , getHelpTextViaBS
   ) where
 
+import Commons (maybeToList, readProcessSimple, headMaybe)
+
 import Help.Subcommand
 
 import Data.Aeson
 
 import Data.Aeson.Types (typeMismatch)
 import Data.List (inits)
 import GHC.Generics (Generic)
-import System.Directory (doesFileExist, getCurrentDirectory)
+import System.Directory (listDirectory, doesDirectoryExist, doesFileExist, getCurrentDirectory)
 import System.FilePath (joinPath, (</>), splitDirectories)
 
+import qualified Data.Text as T
+
 data BuildSystem = Cabal | Cargo | Stack
   deriving (Eq, Show, Generic)
 
@@ -32,6 +37,18 @@ instance FromJSON BuildSystem where
     _ -> fail "Unrecognized build system."
   parseJSON invalid = typeMismatch "Build system" invalid
 
+getHelpTextViaBS :: BuildSystem -> String -> [Subcommand] -> [String] -> IO (Maybe T.Text)
+getHelpTextViaBS bs bin subcs args = case bs of
+  Stack -> do
+    binpath <- stackFindBinary bin
+    case binpath of
+      Nothing -> pure Nothing
+      Just p -> readProcessSimple p args'
+  Cabal -> readProcessSimple "cabal" (["v2-exec", bin, "--"] <> args')
+  Cargo -> readProcessSimple "cargo" (["run", "--bin", bin, "--"] <> args')
+  where
+    args' = map show subcs <> args
+
 mkExecArgs :: BuildSystem -> String -> [Subcommand] -> (String, [String])
 mkExecArgs bs bin subcs = case bs of
   Stack -> ("stack", ["exec", bin, "--"] <> map show subcs)
@@ -51,3 +68,24 @@ checkTillRoot bs = do
   let dirs = splitDirectories cwd
   fexists <- traverse (doesFileExist . (</> s) . joinPath) $ reverse (inits dirs)
   pure (or fexists)
+
+stackFindBinary :: String -> IO (Maybe FilePath)
+stackFindBinary binName = do
+  stack_path_m <- readProcessSimple "stack" ["path"]
+  let search_root = do
+        stack_paths <- T.lines <$> stack_path_m
+        let getPath s = headMaybe . map (T.strip . T.drop (T.length s))
+              $ filter (T.isPrefixOf s) stack_paths
+        proj_root <- getPath "project-root:"
+        dist_dir <- getPath "dist-dir:"
+        pure (T.unpack proj_root </> T.unpack dist_dir)
+  go (maybeToList search_root)
+  where
+    go [] = pure Nothing
+    go (x:xs) = do
+      isDir <- doesDirectoryExist x
+      if isDir then do
+        gotcha <- doesFileExist (x </> binName)
+        if gotcha then pure (Just (x </> binName))
+        else (\ys -> go (map (x </>) ys ++ xs)) =<< listDirectory x
+      else go xs

src/Help/Page.hs

@@ -33,7 +33,7 @@ module Help.Page
 
 import Commons
 
-import Development.BuildSystem (mkExecArgs)
+import Development.BuildSystem (getHelpTextViaBS, mkExecArgs)
 import Help.Page.Help
 import Help.Page.Internal
 import Help.Page.Lenses (binaryPath, section, name, subcommandPath, anchors)
@@ -85,6 +85,11 @@ displayHelpPageSummary (HelpPageSummary bp scp sh _) =
   where
     hstr = if sh then "-h" else "--help"
 
+mkProcessArgs :: BinaryPath -> [Subcommand] -> (String, [String])
+mkProcessArgs bp subcs = case bp of
+  Global fp -> (fp, map show subcs)
+  Local _pf bs bin -> mkExecArgs bs bin subcs
+
 ----------------------------------------------------------------------
 -- ** Fetching documentation using summaries
 
@@ -105,20 +110,16 @@ getManPage mps = do
     else T.readFile path
   pure (Just (Man mps (parseManPage txt)))
 
-mkProcessArgs :: BinaryPath -> [Subcommand] -> (String, [String])
-mkProcessArgs bp subcs = case bp of
-  Global fp -> (fp, map show subcs)
-  Local _pf bs bin -> mkExecArgs bs bin subcs
-
 getHelpPageSummary :: BinaryPath -> [Subcommand] -> IO (Maybe HelpPageSummary)
 getHelpPageSummary binPath subcPath = do
   d1 <- go ["-h"]
   d2 <- fmap (mkHPS False) <$> go ["--help"]
   pure $ maybe d2 (Just . mkHPS True) d1
   where
     mkHPS = HelpPageSummary binPath subcPath
-    go hstr = uncurry readProcessSimple $ (<> hstr)
-      <$> mkProcessArgs binPath subcPath
+    go hstr = case binPath of
+      Global fp -> readProcessSimple fp (map show subcPath <> hstr)
+      Local _pf bs bin -> getHelpTextViaBS bs bin subcPath hstr
 
 getManPageSummary :: Text -> Text -> IO (Maybe ManPageSummary)
 getManPageSummary (unpack -> name_) (unpack -> section_) = do
@@ -132,8 +133,9 @@ getHelpPage hsum@(HelpPageSummary binPath subcPath short _) =
   let hstr = if short then ["-h"] else ["--help"]
   in fmap (Help hsum . parseHelpPage) <$> go hstr
   where
-    go hstr = uncurry readProcessSimple $ (<> hstr)
-      <$> mkProcessArgs binPath subcPath
+    go hstr = case binPath of
+      Global fp -> readProcessSimple fp (map show subcPath <> hstr)
+      Local _pf bs bin -> getHelpTextViaBS bs bin subcPath hstr
 
 ----------------------------------------------------------------------
 -- ** Saving summaries for later use