Replaced stack ide targets and stack list-dependencies with a sta…

…ck script DirectDeps.hs

Due to commercialhaskell/stack#3695

README.md

@@ -4,7 +4,7 @@
 
 * > cannot satisfy -package quickcheck-instances-0.3.12
 
-    You might have to run `stack build && stack test` once
+    You might have to run `stack build --test` once
 
 ## This is the README for the "languageprovider-sample"
 

client/scripts/DirectDeps.hs

@@ -0,0 +1,179 @@
+#!/usr/bin/env stack
+{- stack
+  script
+  --resolver lts-10.1
+  --package Cabal
+  --package yaml
+  --package process
+  --package bytestring
+  --package unordered-containers
+  --package text
+  --package filepath
+  --package aeson
+  --package vector
+-}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+
+module DirectDeps where
+
+import Data.Aeson         (FromJSON, ToJSON, Value(..), (.:), (.=), withObject, toJSON, object)
+import Data.List          (isPrefixOf)
+import Data.Maybe         (fromMaybe, maybeToList)
+import Data.Text          (Text)
+import Data.Vector        (fromList)
+import System.Environment (getArgs)
+import System.Exit        (die, ExitCode(..))
+import System.FilePath    ((</>), (<.>))
+import System.Process     (readCreateProcessWithExitCode, proc, cwd)
+
+import qualified Data.Aeson                             as J
+import qualified Data.ByteString.Char8                  as BS
+import qualified Data.ByteString.Lazy.Char8             as BSL
+import qualified Data.HashMap.Strict                    as HM
+import qualified Data.Text                              as T
+import qualified Data.Yaml                              as Y
+import qualified Distribution.Package                   as P
+import qualified Distribution.PackageDescription        as P
+import qualified Distribution.PackageDescription.Parse  as P
+import qualified Distribution.Types.UnqualComponentName as P
+import qualified Distribution.Verbosity                 as P
+
+main :: IO ()
+main = do
+  argsOpt               <- parseArgs <$> getArgs
+  (projPath, stackPath) <- case argsOpt of
+                            Just args -> pure args
+                            Nothing   -> die usage
+  cabalFiles            <- stackQuery projPath stackPath
+  packageDescriptions   <- traverse readGenericPackageDescriptionFromFile cabalFiles
+  let packages = fmap parsePackage packageDescriptions
+  putStrLn $ BSL.unpack $ J.encode packages
+
+-------------------------------------------------------------------
+-- parse cabal files
+-------------------------------------------------------------------
+
+data Package = Package
+  { packageName :: String
+  , packageComponents :: [Component]
+  }
+
+data Component
+  = Lib [P.Dependency]
+  | Other ComponentType ComponentName DependsOnLib [P.Dependency]
+
+type ComponentName = String
+type DependsOnLib = Bool
+data ComponentType = Exe | Test | Bench
+
+instance ToJSON Package where
+  toJSON (Package pkgName components) = 
+    object
+      [ "packageName" .= pkgName
+      , "components" .= fromList (map encodeComponent components)
+      ]
+    where
+      encodeComponent (Lib deps) =
+        object
+          [ "target"  .= pkgName
+          , "deps"    .= fromList (map encodeDep deps)
+          ]
+      encodeComponent (Other ctype cname dependsOnLib deps) =
+        object
+          [ "target"        .= (pkgName ++ ":" ++ encodeCtype ctype ++ ":"  ++ cname)
+          , "dependsOnLib"  .= dependsOnLib
+          , "deps"          .= fromList (map encodeDep deps)
+          ]
+      encodeDep = toJSON . P.unPackageName . P.depPkgName
+      encodeCtype Exe   = "exe"
+      encodeCtype Test  = "test"
+      encodeCtype Bench = "bench"
+
+readGenericPackageDescriptionFromFile :: CabalFile -> IO P.GenericPackageDescription
+readGenericPackageDescriptionFromFile cf = P.readGenericPackageDescription P.normal fullPath
+  where
+    fullPath = T.unpack (path cf) </> T.unpack (name cf) <.> "cabal"
+
+parsePackage :: P.GenericPackageDescription -> Package
+parsePackage gpd =
+  let pkgName = P.unPackageName $ P.pkgName $ P.package $ P.packageDescription gpd
+      lib     = Lib . P.condTreeConstraints <$> P.condLibrary gpd
+      exes    = parseComponent Exe   pkgName <$> P.condExecutables gpd
+      tests   = parseComponent Test  pkgName <$> P.condTestSuites gpd
+      benches = parseComponent Bench pkgName <$> P.condBenchmarks gpd
+      components = maybeToList lib ++ exes ++ tests ++ benches
+  in  Package pkgName components
+
+parseComponent
+  :: ComponentType
+  -> String
+  -> (P.UnqualComponentName, P.CondTree b [P.Dependency] c)
+  -> Component
+parseComponent componentType pkgName (compName, condTree) =
+  let compName'     = P.unUnqualComponentName compName
+      deps          = P.condTreeConstraints condTree
+      dependsOnLib  = any (\d -> P.unPackageName (P.depPkgName d) == pkgName) deps
+  in  Other componentType compName' dependsOnLib deps
+
+-------------------------------------------------------------------
+-- parse command line args
+-------------------------------------------------------------------
+
+type ProjectPath = String
+type StackPath = String
+
+parseArgs :: [String] -> Maybe (ProjectPath, StackPath)
+parseArgs args =
+  go args (Nothing, Nothing) >>= \case
+    (Nothing, _) -> Nothing
+    (Just projPath, stackPathOpt) -> Just (projPath, fromMaybe "stack" stackPathOpt)
+  where
+    go :: [String] -> (Maybe ProjectPath, Maybe StackPath) -> Maybe (Maybe ProjectPath, Maybe StackPath)
+    go [] paths = Just paths
+    go (stackFlag : stackPath : xs) (projPathOpt, _)
+      | stackFlag == "-s" || stackFlag == "--stack-path" = go xs (projPathOpt, Just stackPath)
+    go (unrecognizedFlag : _) _
+      | "-" `isPrefixOf` unrecognizedFlag  = Nothing
+    go (projPath : xs) (_, stackPathOpt) = go xs (Just projPath, stackPathOpt)
+
+usage :: String
+usage = "Usage: stack DirectDeps.hs <project-path> [-s|--stack-path <stack-path>]"
+
+-------------------------------------------------------------------
+-- `stack query`
+-------------------------------------------------------------------
+
+stackQuery :: ProjectPath -> StackPath -> IO [CabalFile]
+stackQuery projPath stackPath = 
+  do
+    (exitCode, stdout, stderr) <- readCreateProcessWithExitCode process ""
+
+    case exitCode of
+      ExitFailure _ -> die ("`stack query` failed:\n" ++ stderr)
+      ExitSuccess   -> pure ()
+
+    case Y.decodeEither (BS.pack stdout) of
+      Right (StackQuery files)  -> pure files
+      Left err                  -> die ("Could not parse response from `stack query`:\n" ++ err)
+  where
+    process = (proc stackPath ["query"]) { cwd = Just projPath }
+
+newtype StackQuery = StackQuery [CabalFile]
+
+data CabalFile = CabalFile
+  { name :: Text
+  , path :: Text
+  }
+
+instance FromJSON StackQuery where
+  parseJSON = 
+    let parseCabalFile (k, v) = 
+          withObject (T.unpack k) (\v' -> CabalFile k <$> v' .: "path") v
+    in
+      withObject "root" $ \o ->
+        do 
+          Object locals <- o .: "locals"
+          files         <- traverse parseCabalFile $ HM.toList locals
+          pure $ StackQuery files

client/src/extension.ts

@@ -38,6 +38,9 @@ function startLangServer(context: ExtensionContext) {
 			configurationSection: 'lspSample',
 			// Notify the server about file changes to '.clientrc files contain in the workspace
 			fileEvents: workspace.createFileSystemWatcher('**/.clientrc')
+		},
+		initializationOptions: {
+			directDepsScript: context.asAbsolutePath(path.join('scripts', 'DirectDeps.hs'))
 		}
 	}
 

server/src/server.ts

@@ -34,7 +34,9 @@ let workspaceRoot: string;
 connection.onInitialize(async (params): Promise<InitializeResult> => {
 	workspaceRoot = params.rootPath;
 
-	const targets = await stack.getTargets(workspaceRoot);
+	const directDepsScript = params.initializationOptions.directDepsScript
+
+	const targets = await stack.getTargets(workspaceRoot, directDepsScript);
 
 	console.log('Initializing targets:');
 	targets.map(x => console.log(x));

server/src/stack.ts

@@ -1,69 +1,36 @@
 import * as cp from 'child_process';
+import * as cpUtils from './utils/childProcess';
 import * as regex from './utils/regex';
+import * as _ from 'lodash';
 
 type Target = string
 type PkgName = string
 type Dependencies = string
 
-export async function getTargets(root: string): Promise<Target[][]> {
+export async function getTargets(root: string, directDepsScript: string): Promise<Target[][]> {
+  // TODO: pass stackpath here with --stack-path
+  const [err, stdout, stderr] = await cpUtils.exec_(`stack ${directDepsScript} ${root}`);
 
-  const targetsAndPkg = await getTargetsAndPkg(root);
+  if (err) return Promise.reject(err);
+  if (stderr) return Promise.reject(stderr);
 
-  const targets = await Promise.all(targetsAndPkg.map(async t => {
-    const [target, pkgName] = t;
-    const deps = await getDependencies(root, target);
-
-    if ( ! /^hspec .*$/mg.test(deps))
-      return [];
+  const packages = JSON.parse(stdout);
 
-    if (new RegExp(`^${pkgName} .*$`, 'mg').test(deps))
-      return [target, `${pkgName}:lib`];
-
-    return [target];
-  }).map(p => p.catch(error => {
-    console.log('Could not get the dependencies for target.');
-    console.log(JSON.stringify(error, null, 2));
-    return [];
-  })));
-
-  return targets.filter(ts => ts.length > 0);
-}
-
-function getTargetsAndPkg(root: string): Promise<[Target, PkgName][]> {
-
-  return new Promise<[Target, PkgName][]>((resolve, reject) => {
-
-    const cwd = process.cwd();
-    process.chdir(root);
-
-    cp.exec(`stack ide targets`, (error, stdout, stderr) => {
-      if (error) reject(error);
-      if (!stderr) resolve([]);
-
-      resolve(parseTargets(stderr));
-    });
-
-    process.chdir(cwd);
-  });
-}
-
-function getDependencies(root: string, target: Target): Promise<Dependencies> {
-  return new Promise((resolve, reject) => {
-
-    const cwd = process.cwd();
-    process.chdir(root);
-
-    cp.exec(`stack list-dependencies ${target} --depth 1`, (error, stdout, stderr) => {
-      if (error) reject(error);
-      // if (stderr) reject(stderr);
-
-      resolve(stdout);
-    });
-
-    process.chdir(cwd);
-  });
+  return _(packages)
+    .flatMap(p => p.components)
+    .filter(c => /^.+:test:.+$/mg.test(c.target))
+    .filter(c => c.deps.includes('hspec'))
+    .map(c => 
+      c.dependsOnLib ? [c.target, getLibForTarget(c.target)] : [c.target]
+    )
+    .value();
 }
 
-function parseTargets(text: string): [Target, PkgName][] {
-  return regex.extract(text, /^(.+):test:.+$/mg).map(m => <[Target, PkgName]> [m[0], m[1]]);
+/** Deduce the target for the library component of a test suite. E.g. `halive:test:unit` -> `halive:lib` */
+function getLibForTarget(target: string): string {
+  return regex
+          .extract(target, /^(.+?):/mg)
+          [0]   // get first match
+          [1]   // get first capture group
+          + ":lib";
 }

server/src/utils/childProcess.ts

@@ -0,0 +1,22 @@
+import * as cp from 'child_process';
+
+type Stderr = string;
+type Stdout = string;
+
+export function exec(dir: string, cmd: string): Promise<[Error, Stdout, Stderr]> {
+  return new Promise((resolve, reject) => {
+
+    const cwd = process.cwd();
+    process.chdir(dir);
+
+    cp.exec(cmd, (error, stdout, stderr) => resolve([error, stdout, stderr]));
+
+    process.chdir(cwd);
+  });
+}
+
+export function exec_(cmd: string): Promise<[Error, Stdout, Stderr]> {
+  return new Promise((resolve, reject) => {
+    cp.exec(cmd, (error, stdout, stderr) => resolve([error, stdout, stderr]));
+  });
+}