-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE CPP             #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections   #-}
{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above

module Ide.Arguments
  ( Arguments(..)
  , GhcideArguments(..)
  , PrintVersion(..)
  , BiosAction(..)
  , getArguments
  , haskellLanguageServerVersion
  , haskellLanguageServerNumericVersion
  ) where

import           Data.Version
import           Development.IDE               (IdeState)
import           Development.IDE.Main          (Command (..), commandP)
import           GitHash                       (giHash, tGitInfoCwdTry)
import           Ide.Types                     (IdePlugins)
import           Options.Applicative
import           Paths_haskell_language_server
import           System.Environment

-- ---------------------------------------------------------------------

data Arguments
  = VersionMode PrintVersion
  | ProbeToolsMode
  | ListPluginsMode
  | BiosMode BiosAction
  | Ghcide GhcideArguments
  | VSCodeExtensionSchemaMode
  | DefaultConfigurationMode
  | PrintLibDir

data GhcideArguments = GhcideArguments
    {GhcideArguments -> Command
argsCommand            :: Command
    ,GhcideArguments -> Maybe FilePath
argsCwd                :: Maybe FilePath
    ,GhcideArguments -> Maybe FilePath
argsShakeProfiling     :: Maybe FilePath
    ,GhcideArguments -> Bool
argsTesting            :: Bool
    ,GhcideArguments -> Bool
argsExamplePlugin      :: Bool
    -- These next two are for compatibility with existing hie clients, allowing
    -- them to just change the name of the exe and still work.
    , GhcideArguments -> Bool
argsDebugOn           :: Bool
    , GhcideArguments -> Maybe FilePath
argsLogFile           :: Maybe String
    , GhcideArguments -> Int
argsThreads           :: Int
    , GhcideArguments -> Bool
argsProjectGhcVersion :: Bool
    } deriving Int -> GhcideArguments -> ShowS
[GhcideArguments] -> ShowS
GhcideArguments -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [GhcideArguments] -> ShowS
$cshowList :: [GhcideArguments] -> ShowS
show :: GhcideArguments -> FilePath
$cshow :: GhcideArguments -> FilePath
showsPrec :: Int -> GhcideArguments -> ShowS
$cshowsPrec :: Int -> GhcideArguments -> ShowS
Show

data PrintVersion
  = PrintVersion
  | PrintNumericVersion
  deriving (Int -> PrintVersion -> ShowS
[PrintVersion] -> ShowS
PrintVersion -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [PrintVersion] -> ShowS
$cshowList :: [PrintVersion] -> ShowS
show :: PrintVersion -> FilePath
$cshow :: PrintVersion -> FilePath
showsPrec :: Int -> PrintVersion -> ShowS
$cshowsPrec :: Int -> PrintVersion -> ShowS
Show, PrintVersion -> PrintVersion -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrintVersion -> PrintVersion -> Bool
$c/= :: PrintVersion -> PrintVersion -> Bool
== :: PrintVersion -> PrintVersion -> Bool
$c== :: PrintVersion -> PrintVersion -> Bool
Eq, Eq PrintVersion
PrintVersion -> PrintVersion -> Bool
PrintVersion -> PrintVersion -> Ordering
PrintVersion -> PrintVersion -> PrintVersion
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PrintVersion -> PrintVersion -> PrintVersion
$cmin :: PrintVersion -> PrintVersion -> PrintVersion
max :: PrintVersion -> PrintVersion -> PrintVersion
$cmax :: PrintVersion -> PrintVersion -> PrintVersion
>= :: PrintVersion -> PrintVersion -> Bool
$c>= :: PrintVersion -> PrintVersion -> Bool
> :: PrintVersion -> PrintVersion -> Bool
$c> :: PrintVersion -> PrintVersion -> Bool
<= :: PrintVersion -> PrintVersion -> Bool
$c<= :: PrintVersion -> PrintVersion -> Bool
< :: PrintVersion -> PrintVersion -> Bool
$c< :: PrintVersion -> PrintVersion -> Bool
compare :: PrintVersion -> PrintVersion -> Ordering
$ccompare :: PrintVersion -> PrintVersion -> Ordering
Ord)

data BiosAction
  = PrintCradleType
  deriving (Int -> BiosAction -> ShowS
[BiosAction] -> ShowS
BiosAction -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [BiosAction] -> ShowS
$cshowList :: [BiosAction] -> ShowS
show :: BiosAction -> FilePath
$cshow :: BiosAction -> FilePath
showsPrec :: Int -> BiosAction -> ShowS
$cshowsPrec :: Int -> BiosAction -> ShowS
Show, BiosAction -> BiosAction -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BiosAction -> BiosAction -> Bool
$c/= :: BiosAction -> BiosAction -> Bool
== :: BiosAction -> BiosAction -> Bool
$c== :: BiosAction -> BiosAction -> Bool
Eq, Eq BiosAction
BiosAction -> BiosAction -> Bool
BiosAction -> BiosAction -> Ordering
BiosAction -> BiosAction -> BiosAction
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BiosAction -> BiosAction -> BiosAction
$cmin :: BiosAction -> BiosAction -> BiosAction
max :: BiosAction -> BiosAction -> BiosAction
$cmax :: BiosAction -> BiosAction -> BiosAction
>= :: BiosAction -> BiosAction -> Bool
$c>= :: BiosAction -> BiosAction -> Bool
> :: BiosAction -> BiosAction -> Bool
$c> :: BiosAction -> BiosAction -> Bool
<= :: BiosAction -> BiosAction -> Bool
$c<= :: BiosAction -> BiosAction -> Bool
< :: BiosAction -> BiosAction -> Bool
$c< :: BiosAction -> BiosAction -> Bool
compare :: BiosAction -> BiosAction -> Ordering
$ccompare :: BiosAction -> BiosAction -> Ordering
Ord)

getArguments :: String -> IdePlugins IdeState -> IO Arguments
getArguments :: FilePath -> IdePlugins IdeState -> IO Arguments
getArguments FilePath
exeName IdePlugins IdeState
plugins = forall a. ParserInfo a -> IO a
execParser ParserInfo Arguments
opts
  where
    opts :: ParserInfo Arguments
opts = forall a. Parser a -> InfoMod a -> ParserInfo a
info ((
      PrintVersion -> Arguments
VersionMode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Parser PrintVersion
printVersionParser FilePath
exeName
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FilePath -> Parser Arguments
probeToolsParser FilePath
exeName
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. Mod CommandFields a -> Parser a
hsubparser
        (  forall a. FilePath -> ParserInfo a -> Mod CommandFields a
command FilePath
"vscode-extension-schema" ParserInfo Arguments
extensionSchemaCommand
        forall a. Semigroup a => a -> a -> a
<> forall a. FilePath -> ParserInfo a -> Mod CommandFields a
command FilePath
"generate-default-config" ParserInfo Arguments
generateDefaultConfigCommand
        )
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Arguments
listPluginsParser
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> BiosAction -> Arguments
BiosMode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser BiosAction
biosParser
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> GhcideArguments -> Arguments
Ghcide forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IdePlugins IdeState -> Parser GhcideArguments
arguments IdePlugins IdeState
plugins
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Mod FlagFields a -> Parser a
flag' Arguments
PrintLibDir (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"print-libdir" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Print project GHCs libdir")
      )
      forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> forall a. Parser (a -> a)
helper)
      ( forall a. InfoMod a
fullDesc
     forall a. Semigroup a => a -> a -> a
<> forall a. FilePath -> InfoMod a
progDesc FilePath
"Used as a test bed to check your IDE Client will work"
     forall a. Semigroup a => a -> a -> a
<> forall a. FilePath -> InfoMod a
header (FilePath
exeName forall a. [a] -> [a] -> [a]
++ FilePath
" - GHC Haskell LSP server"))

    extensionSchemaCommand :: ParserInfo Arguments
extensionSchemaCommand =
        forall a. Parser a -> InfoMod a -> ParserInfo a
info (forall (f :: * -> *) a. Applicative f => a -> f a
pure Arguments
VSCodeExtensionSchemaMode)
             (forall a. InfoMod a
fullDesc forall a. Semigroup a => a -> a -> a
<> forall a. FilePath -> InfoMod a
progDesc FilePath
"Print generic config schema for plugins (used in the package.json of haskell vscode extension)")
    generateDefaultConfigCommand :: ParserInfo Arguments
generateDefaultConfigCommand =
        forall a. Parser a -> InfoMod a -> ParserInfo a
info (forall (f :: * -> *) a. Applicative f => a -> f a
pure Arguments
DefaultConfigurationMode)
             (forall a. InfoMod a
fullDesc forall a. Semigroup a => a -> a -> a
<> forall a. FilePath -> InfoMod a
progDesc FilePath
"Print config supported by the server with default values")

printVersionParser :: String -> Parser PrintVersion
printVersionParser :: FilePath -> Parser PrintVersion
printVersionParser FilePath
exeName =
  forall a. a -> Mod FlagFields a -> Parser a
flag' PrintVersion
PrintVersion
    (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"version" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help (FilePath
"Show " forall a. [a] -> [a] -> [a]
++ FilePath
exeName  forall a. [a] -> [a] -> [a]
++ FilePath
" and GHC versions"))
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  forall a. a -> Mod FlagFields a -> Parser a
flag' PrintVersion
PrintNumericVersion
    (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"numeric-version" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help (FilePath
"Show numeric version of " forall a. [a] -> [a] -> [a]
++ FilePath
exeName))

biosParser :: Parser BiosAction
biosParser :: Parser BiosAction
biosParser =
  forall a. a -> Mod FlagFields a -> Parser a
flag' BiosAction
PrintCradleType
    (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"print-cradle" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Print the project cradle type")

probeToolsParser :: String -> Parser Arguments
probeToolsParser :: FilePath -> Parser Arguments
probeToolsParser FilePath
exeName =
  forall a. a -> Mod FlagFields a -> Parser a
flag' Arguments
ProbeToolsMode
    (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"probe-tools" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help (FilePath
"Show " forall a. [a] -> [a] -> [a]
++ FilePath
exeName  forall a. [a] -> [a] -> [a]
++ FilePath
" version and other tools of interest"))

listPluginsParser :: Parser Arguments
listPluginsParser :: Parser Arguments
listPluginsParser =
  forall a. a -> Mod FlagFields a -> Parser a
flag' Arguments
ListPluginsMode
    (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"list-plugins" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"List all available plugins")

arguments :: IdePlugins IdeState -> Parser GhcideArguments
arguments :: IdePlugins IdeState -> Parser GhcideArguments
arguments IdePlugins IdeState
plugins = Command
-> Maybe FilePath
-> Maybe FilePath
-> Bool
-> Bool
-> Bool
-> Maybe FilePath
-> Int
-> Bool
-> GhcideArguments
GhcideArguments
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IdePlugins IdeState -> Parser Command
commandP IdePlugins IdeState
plugins forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Command
lspCommand forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Command
checkCommand)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall s. IsString s => Mod OptionFields s -> Parser s
strOption forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"cwd" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"DIR"
                  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Change to this directory")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall s. IsString s => Mod OptionFields s -> Parser s
strOption forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"shake-profiling" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"DIR"
                  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Dump profiling reports to this directory")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"test"
                  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Enable additional lsp messages used by the testsuite")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"example"
                  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Include the Example Plugin. For Plugin devs only")

      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
           ( forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"debug"
          forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'd'
          forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Generate debug output"
           )
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall s. IsString s => Mod OptionFields s -> Parser s
strOption
           ( forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"logfile"
          forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'l'
          forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"LOGFILE"
          forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"File to log to, defaults to stdout"
           ))
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto
           (forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'j'
          forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Number of threads (0: automatic)"
          forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NUM"
          forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Int
0
          forall a. Semigroup a => a -> a -> a
<> forall a (f :: * -> *). Show a => Mod f a
showDefault
           )
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"project-ghc-version"
                  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Work out the project GHC version and print it")
    where
        lspCommand :: Parser Command
lspCommand = Command
LSP forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. a -> Mod FlagFields a -> Parser a
flag' Bool
True (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"lsp" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Start talking to an LSP server")
        checkCommand :: Parser Command
checkCommand = [FilePath] -> Command
Check forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument forall s. IsString s => ReadM s
str (forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"FILES/DIRS..."))

-- ---------------------------------------------------------------------

haskellLanguageServerNumericVersion :: String
haskellLanguageServerNumericVersion :: FilePath
haskellLanguageServerNumericVersion = Version -> FilePath
showVersion Version
version

haskellLanguageServerVersion :: IO String
haskellLanguageServerVersion :: IO FilePath
haskellLanguageServerVersion = do
  FilePath
path <- IO FilePath
getExecutablePath
  let gi :: Either FilePath GitInfo
gi = $$FilePath
forall a b. a -> Either a b
tGitInfoCwdTry
      gitHashSection :: FilePath
gitHashSection = case Either FilePath GitInfo
gi of
        Right GitInfo
gi -> FilePath
" (GIT hash: " forall a. Semigroup a => a -> a -> a
<> GitInfo -> FilePath
giHash GitInfo
gi forall a. Semigroup a => a -> a -> a
<> FilePath
")"
        Left FilePath
_   -> FilePath
""
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath
"haskell-language-server version: " forall a. Semigroup a => a -> a -> a
<> FilePath
haskellLanguageServerNumericVersion
             forall a. Semigroup a => a -> a -> a
<> FilePath
" (GHC: " forall a. Semigroup a => a -> a -> a
<> VERSION_ghc
             forall a. Semigroup a => a -> a -> a
<> FilePath
") (PATH: " forall a. Semigroup a => a -> a -> a
<> FilePath
path forall a. Semigroup a => a -> a -> a
<> FilePath
")"
             forall a. Semigroup a => a -> a -> a
<> FilePath
gitHashSection