Brute-force copy of install.hs from hie

Renamed the string stuff to be "haskell-ide-" instead of "hie-",
nothing else changed.

Initial hand tests show it working for stack installs.

Closes haskell#14

Author: alanz

install.hs

@@ -0,0 +1,21 @@
+#!/usr/bin/env stack
+{- stack
+  runghc
+  --stack-yaml=install/shake.yaml
+  --package hie-install
+-}
+{- cabal:
+build-depends:
+    base
+  , hie-install
+-}
+-- call as:
+-- * `cabal v2-run install.hs --project-file install/shake.project <target>`
+-- * `stack install.hs <target>`
+
+-- TODO: set `shake.project` in cabal-config above, when supported
+-- (see https://github.com/haskell/cabal/issues/6353)
+
+import HieInstall (defaultMain)
+
+main = defaultMain

install/Setup.hs

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

install/cabal.project

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

install/hie-install.cabal

@@ -0,0 +1,40 @@
+name:                hie-install
+version:             0.8.0.0
+synopsis:            Install the haskell-ide-engine
+license:             BSD3
+author:              Many, TBD when we release
+maintainer:          [email protected]
+copyright:           2019
+build-type:          Simple
+cabal-version:       >=2.0
+
+library
+  hs-source-dirs:      src
+  exposed-modules:     HieInstall
+  other-modules:       BuildSystem
+                     , Stack
+                     , Version
+                     , Cabal
+                     , Print
+                     , Env
+                     , Help
+  build-depends:       base >= 4.9 && < 5
+                     , shake >= 0.16.4 && < 0.19
+                     , directory
+                     , filepath
+                     , extra
+                     , text
+  default-extensions: LambdaCase
+                    , TupleSections
+                    , RecordWildCards
+  default-language:    Haskell2010
+
+  if flag(run-from-stack)
+    cpp-options:       -DRUN_FROM_STACK
+  else
+    build-depends: cabal-install-parsers
+
+flag run-from-stack
+  description:         Inform the application that it is run from stack
+  default:             False
+  manual:              True

install/shake.project

@@ -0,0 +1,2 @@
+packages:
+         install/

install/shake.yaml

@@ -0,0 +1,11 @@
+# Used to provide a different environment for the shake build script
+resolver: lts-14.11 # GHC 8.6.5
+packages:
+- .
+
+nix:
+  packages: [ zlib ]
+
+flags:
+  hie-install:
+    run-from-stack: true

install/src/BuildSystem.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE CPP #-}
+
+module BuildSystem where
+
+buildSystem :: String
+buildSystem =
+#if RUN_FROM_STACK
+  "stack"
+#else
+  "cabal"
+#endif
+
+isRunFromStack :: Bool
+isRunFromStack = buildSystem == "stack"
+
+isRunFromCabal :: Bool
+isRunFromCabal = buildSystem == "cabal"

install/src/Cabal.hs

@@ -0,0 +1,122 @@
+{-# LANGUAGE CPP #-}
+
+module Cabal where
+
+import           Development.Shake
+import           Development.Shake.Command
+import           Development.Shake.FilePath
+import           Control.Monad
+import           Data.Maybe                               ( isNothing
+                                                          , isJust
+                                                          )
+import           Control.Monad.Extra                      ( whenMaybe )
+import           System.Directory                         ( findExecutable
+                                                          , copyFile
+                                                          )
+
+import           Version
+import           Print
+import           Env
+import           Data.Functor.Identity
+#if RUN_FROM_STACK
+import           Control.Exception                        ( throwIO )
+#else
+import           Cabal.Config
+#endif
+
+getInstallDir :: IO FilePath
+#if RUN_FROM_STACK
+-- we should never hit this codepath
+getInstallDir = throwIO $ userError "Stack and cabal should never be mixed"
+#else
+getInstallDir = runIdentity . cfgInstallDir <$> readConfig
+#endif
+
+execCabal :: CmdResult r => [String] -> Action r
+execCabal = command [] "cabal"
+
+execCabal_ :: [String] -> Action ()
+execCabal_ = command [] "cabal"
+
+cabalBuildData :: Action ()
+cabalBuildData = do
+  execCabal_ ["v2-build", "hoogle"]
+  execCabal_ ["v2-exec", "hoogle", "generate"]
+
+getGhcPathOfOrThrowError :: VersionNumber -> Action GhcPath
+getGhcPathOfOrThrowError versionNumber =
+  getGhcPathOf versionNumber >>= \case
+    Nothing -> do
+      printInStars $ ghcVersionNotFoundFailMsg versionNumber
+      error (ghcVersionNotFoundFailMsg versionNumber)
+    Just p -> return p
+
+cabalInstallHie :: VersionNumber -> Action ()
+cabalInstallHie versionNumber = do
+  localBin <- liftIO $ getInstallDir
+  cabalVersion <- getCabalVersion
+  ghcPath <- getGhcPathOfOrThrowError versionNumber
+
+  let isCabal3 = checkVersion [3,0,0,0] cabalVersion
+      installDirOpt | isCabal3 = "--installdir"
+                    | otherwise = "--symlink-bindir"
+      installMethod | isWindowsSystem && isCabal3 = ["--install-method=copy"]
+                    | otherwise = []
+  execCabal_ $
+    [ "v2-install"
+    , "-w", ghcPath
+    , "--write-ghc-environment-files=never"
+    , installDirOpt, localBin
+    , "--max-backjumps=5000"
+    , "exe:haskell-ide"
+    , "--overwrite-policy=always"
+    ]
+    ++ installMethod
+
+  let minorVerExe = "haskell-ide-" ++ versionNumber <.> exe
+      majorVerExe = "haskell-ide-" ++ dropExtension versionNumber <.> exe
+
+  liftIO $ do
+    copyFile (localBin </> "haskell-ide" <.> exe) (localBin </> minorVerExe)
+    copyFile (localBin </> "haskell-ide" <.> exe) (localBin </> majorVerExe)
+
+  printLine $   "Copied executables "
+             ++ ("haskell-ide-wrapper" <.> exe) ++ ", "
+             ++ ("haskell-ide" <.> exe) ++ ", "
+             ++ majorVerExe ++ " and "
+             ++ minorVerExe
+             ++ " to " ++ localBin
+
+checkCabal_ :: Action ()
+checkCabal_ = checkCabal >> return ()
+
+-- | check `cabal` has the required version
+checkCabal :: Action String
+checkCabal = do
+  cabalVersion <- getCabalVersion
+  unless (checkVersion requiredCabalVersion cabalVersion) $ do
+    printInStars $ cabalInstallIsOldFailMsg cabalVersion
+    error $ cabalInstallIsOldFailMsg cabalVersion
+  return cabalVersion
+
+getCabalVersion :: Action String
+getCabalVersion = trimmedStdout <$> execCabal ["--numeric-version"]
+
+-- | Error message when the `cabal` binary is an older version
+cabalInstallIsOldFailMsg :: String -> String
+cabalInstallIsOldFailMsg cabalVersion =
+  "The `cabal` executable found in $PATH is outdated.\n"
+    ++ "found version is `"
+    ++ cabalVersion
+    ++ "`.\n"
+    ++ "required version is `"
+    ++ versionToString requiredCabalVersion
+    ++ "`."
+
+
+requiredCabalVersion :: RequiredVersion
+requiredCabalVersion | isWindowsSystem = requiredCabalVersionForWindows
+                     | otherwise = [2, 4, 1, 0]
+
+requiredCabalVersionForWindows :: RequiredVersion
+requiredCabalVersionForWindows = [3, 0, 0, 0]

install/src/Env.hs

@@ -0,0 +1,116 @@
+module Env where
+
+import           Development.Shake
+import           Development.Shake.Command
+import           Control.Monad.IO.Class
+import           Control.Monad
+import           Development.Shake.FilePath
+import           System.Info                              ( os
+                                                          , arch
+                                                          )
+import           Data.Maybe                               ( isJust
+                                                          , isNothing
+                                                          , mapMaybe
+                                                          )
+import           System.Directory                         ( findExecutable
+                                                          , findExecutables
+                                                          , listDirectory
+                                                          )
+import           Data.Function                            ( (&)
+                                                          , on
+                                                          )
+import           Data.List                                ( sort
+                                                          , sortBy
+                                                          , isInfixOf
+                                                          , nubBy
+                                                          )
+import           Data.Ord                                 ( comparing )
+import           Control.Monad.Extra                      ( mapMaybeM )
+
+import qualified Data.Text                     as T
+
+import           Version
+import           Print
+
+
+type GhcPath = String
+
+existsExecutable :: MonadIO m => String -> m Bool
+existsExecutable executable = liftIO $ isJust <$> findExecutable executable
+
+
+-- | Check if the current system is windows
+isWindowsSystem :: Bool
+isWindowsSystem = os `elem` ["mingw32", "win32"]
+
+findInstalledGhcs :: IO [(VersionNumber, GhcPath)]
+findInstalledGhcs = do
+  hieVersions <- getHieVersions :: IO [VersionNumber]
+  knownGhcs <- mapMaybeM
+    (\version -> getGhcPathOf version >>= \case
+        Nothing -> return Nothing
+        Just p  -> return $ Just (version, p)
+    )
+    (reverse hieVersions)
+  -- filter out not supported ghc versions
+  availableGhcs <- filter ((`elem` hieVersions) . fst) <$> getGhcPaths
+  return
+    -- sort by version to make it coherent with getHieVersions
+    $ sortBy (comparing fst)
+    -- nub by version. knownGhcs takes precedence.
+    $ nubBy ((==) `on` fst)
+    -- filter out stack provided GHCs (assuming that stack programs path is the default one in linux)
+    $ filter (not . isInfixOf ".stack" . snd) (knownGhcs ++ availableGhcs)
+
+-- | Get the path to a GHC that has the version specified by `VersionNumber`
+-- If no such GHC can be found, Nothing is returned.
+-- First, it is checked whether there is a GHC with the name `ghc-$VersionNumber`.
+-- If this yields no result, it is checked, whether the numeric-version of the `ghc`
+-- command fits to the desired version.
+getGhcPathOf :: MonadIO m => VersionNumber -> m (Maybe GhcPath)
+getGhcPathOf ghcVersion =
+  liftIO $ findExecutable ("ghc-" ++ ghcVersion <.> exe) >>= \case
+    Nothing -> lookup ghcVersion <$> getGhcPaths
+    path -> return path
+
+-- | Get a list of GHCs that are available in $PATH
+getGhcPaths :: MonadIO m => m [(VersionNumber, GhcPath)]
+getGhcPaths = liftIO $ do
+  paths <- findExecutables "ghc"
+  forM paths $ \path -> do
+    Stdout version <- cmd path ["--numeric-version"]
+    return (trim version, path)
+
+-- | No suitable ghc version has been found. Show a message.
+ghcVersionNotFoundFailMsg :: VersionNumber -> String
+ghcVersionNotFoundFailMsg versionNumber =
+  "No GHC with version "
+    <> versionNumber
+    <> " has been found.\n"
+    <> "Either install a fitting GHC, use the stack targets or modify the PATH variable accordingly."
+
+
+-- | Defines all different hie versions that are buildable.
+--
+-- The current directory is scanned for `stack-*.yaml` files.
+getHieVersions :: MonadIO m => m [VersionNumber]
+getHieVersions = do
+  let stackYamlPrefix = T.pack "stack-"
+  let stackYamlSuffix = T.pack ".yaml"
+  files <- liftIO $ listDirectory "."
+  let hieVersions =
+        files
+          & map T.pack
+          & mapMaybe
+              (T.stripPrefix stackYamlPrefix >=> T.stripSuffix stackYamlSuffix)
+          & map T.unpack
+        -- the following line excludes `8.6.3`, `8.8.1` and `8.8.2` on windows systems
+          & filter (\p -> not (isWindowsSystem && p `elem` ["8.6.3", "8.8.1", "8.8.2"]))
+          & sort
+  return hieVersions
+
+
+-- | Most recent version of hie.
+-- Shown in the more concise help message.
+mostRecentHieVersion :: MonadIO m => m VersionNumber
+mostRecentHieVersion = last <$> getHieVersions