{-# LANGUAGE OverloadedStrings #-}

-- | The main function for the @futhark@ command line program.
module Futhark.CLI.Main (main) where

import Control.Exception
import Data.List (sortOn)
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Futhark.CLI.Autotune as Autotune
import qualified Futhark.CLI.Bench as Bench
import qualified Futhark.CLI.C as C
import qualified Futhark.CLI.CUDA as CCUDA
import qualified Futhark.CLI.Check as Check
import qualified Futhark.CLI.Datacmp as Datacmp
import qualified Futhark.CLI.Dataset as Dataset
import qualified Futhark.CLI.Defs as Defs
import qualified Futhark.CLI.Dev as Dev
import qualified Futhark.CLI.Doc as Doc
import qualified Futhark.CLI.LSP as LSP
import qualified Futhark.CLI.Literate as Literate
import qualified Futhark.CLI.Misc as Misc
import qualified Futhark.CLI.Multicore as Multicore
import qualified Futhark.CLI.MulticoreWASM as MulticoreWASM
import qualified Futhark.CLI.OpenCL as OpenCL
import qualified Futhark.CLI.Pkg as Pkg
import qualified Futhark.CLI.PyOpenCL as PyOpenCL
import qualified Futhark.CLI.Python as Python
import qualified Futhark.CLI.Query as Query
import qualified Futhark.CLI.REPL as REPL
import qualified Futhark.CLI.Run as Run
import qualified Futhark.CLI.Test as Test
import qualified Futhark.CLI.WASM as WASM
import Futhark.Error
import Futhark.Util (maxinum)
import Futhark.Util.Options
import GHC.IO.Encoding (setLocaleEncoding)
import GHC.IO.Exception (IOErrorType (..), IOException (..))
import System.Environment
import System.Exit
import System.IO
import Prelude

type Command = String -> [String] -> IO ()

commands :: [(String, (Command, String))]
commands :: [(String, (Command, String))]
commands =
  ((String, (Command, String)) -> String)
-> [(String, (Command, String))] -> [(String, (Command, String))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn
    (String, (Command, String)) -> String
forall a b. (a, b) -> a
fst
    [ (String
"dev", (Command
Dev.main, String
"Run compiler passes directly.")),
      (String
"repl", (Command
REPL.main, String
"Run interactive Read-Eval-Print-Loop.")),
      (String
"run", (Command
Run.main, String
"Run a program through the (slow!) interpreter.")),
      (String
"c", (Command
C.main, String
"Compile to sequential C.")),
      (String
"opencl", (Command
OpenCL.main, String
"Compile to C calling OpenCL.")),
      (String
"cuda", (Command
CCUDA.main, String
"Compile to C calling CUDA.")),
      (String
"multicore", (Command
Multicore.main, String
"Compile to multicore C.")),
      (String
"python", (Command
Python.main, String
"Compile to sequential Python.")),
      (String
"pyopencl", (Command
PyOpenCL.main, String
"Compile to Python calling PyOpenCL.")),
      (String
"wasm", (Command
WASM.main, String
"Compile to WASM with sequential C")),
      (String
"wasm-multicore", (Command
MulticoreWASM.main, String
"Compile to WASM with multicore C")),
      (String
"test", (Command
Test.main, String
"Test Futhark programs.")),
      (String
"bench", (Command
Bench.main, String
"Benchmark Futhark programs.")),
      (String
"dataset", (Command
Dataset.main, String
"Generate random test data.")),
      (String
"datacmp", (Command
Datacmp.main, String
"Compare Futhark data files for equality.")),
      (String
"dataget", (Command
Misc.mainDataget, String
"Extract test data.")),
      (String
"doc", (Command
Doc.main, String
"Generate documentation for Futhark code.")),
      (String
"pkg", (Command
Pkg.main, String
"Manage local packages.")),
      (String
"check", (Command
Check.main, String
"Type-check a program.")),
      (String
"check-syntax", (Command
Misc.mainCheckSyntax, String
"Syntax-check a program.")),
      (String
"imports", (Command
Misc.mainImports, String
"Print all non-builtin imported Futhark files.")),
      (String
"hash", (Command
Misc.mainHash, String
"Print hash of program AST.")),
      (String
"autotune", (Command
Autotune.main, String
"Autotune threshold parameters.")),
      (String
"defs", (Command
Defs.main, String
"Show location and name of all definitions.")),
      (String
"query", (Command
Query.main, String
"Query semantic information about program.")),
      (String
"literate", (Command
Literate.main, String
"Process a literate Futhark program.")),
      (String
"lsp", (Command
LSP.main, String
"Run LSP server.")),
      (String
"thanks", (Command
Misc.mainThanks, String
"Express gratitude."))
    ]

msg :: String
msg :: String
msg =
  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    [String
"<command> options...", String
"Commands:", String
""]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"   " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cmd String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
cmd) Char
' ' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
desc
           | (String
cmd, (Command
_, String
desc)) <- [(String, (Command, String))]
commands
         ]
  where
    k :: Int
k = [Int] -> Int
forall a (f :: * -> *). (Num a, Ord a, Foldable f) => f a -> a
maxinum (((String, (Command, String)) -> Int)
-> [(String, (Command, String))] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ((String, (Command, String)) -> String)
-> (String, (Command, String))
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, (Command, String)) -> String
forall a b. (a, b) -> a
fst) [(String, (Command, String))]
commands) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3

-- | Catch all IO exceptions and print a better error message if they
-- happen.
reportingIOErrors :: IO () -> IO ()
reportingIOErrors :: IO () -> IO ()
reportingIOErrors =
  (IO () -> [Handler ()] -> IO ()) -> [Handler ()] -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip
    IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
catches
    [ (ExitCode -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ExitCode -> IO ()
onExit,
      (InternalError -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler InternalError -> IO ()
onICE,
      (IOException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler IOException -> IO ()
onIOException,
      (SomeException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler SomeException -> IO ()
onError
    ]
  where
    onExit :: ExitCode -> IO ()
    onExit :: ExitCode -> IO ()
onExit = ExitCode -> IO ()
forall e a. Exception e => e -> IO a
throwIO

    onICE :: InternalError -> IO ()
    onICE :: InternalError -> IO ()
onICE (Error ErrorClass
CompilerLimitation Text
s) = do
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"Known compiler limitation encountered.  Sorry."
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"Revise your program or try a different Futhark compiler."
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
s
      ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
    onICE (Error ErrorClass
CompilerBug Text
s) = do
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"Internal compiler error."
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"Please report this at https://github.com/diku-dk/futhark/issues."
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
s
      ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1

    onError :: SomeException -> IO ()
    onError :: SomeException -> IO ()
onError SomeException
e
      | Just AsyncException
UserInterrupt <- SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
asyncExceptionFromException SomeException
e =
          () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- This corresponds to CTRL-C, which is not an error.
      | Bool
otherwise = do
          Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"Internal compiler error (unhandled IO exception)."
          Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"Please report this at https://github.com/diku-dk/futhark/issues"
          Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
          ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1

    onIOException :: IOException -> IO ()
    onIOException :: IOException -> IO ()
onIOException IOException
e
      | IOException -> IOErrorType
ioe_type IOException
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
ResourceVanished =
          ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
      | Bool
otherwise = IOException -> IO ()
forall a e. Exception e => e -> a
throw IOException
e

main :: IO ()
main :: IO ()
main = IO () -> IO ()
reportingIOErrors (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stdout TextEncoding
utf8
  Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stderr TextEncoding
utf8
  TextEncoding -> IO ()
setLocaleEncoding TextEncoding
utf8
  [String]
args <- IO [String]
getArgs
  String
prog <- IO String
getProgName
  case [String]
args of
    String
cmd : [String]
args'
      | Just (Command
m, String
_) <- String -> [(String, (Command, String))] -> Maybe (Command, String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
cmd [(String, (Command, String))]
commands -> Command
m ([String] -> String
unwords [String
prog, String
cmd]) [String]
args'
    [String]
_ -> ()
-> [FunOptDescr ()]
-> String
-> ([String] -> () -> Maybe (IO ()))
-> Command
forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> Command
mainWithOptions () [] String
msg (Maybe (IO ()) -> () -> Maybe (IO ())
forall a b. a -> b -> a
const (Maybe (IO ()) -> () -> Maybe (IO ()))
-> ([String] -> Maybe (IO ())) -> [String] -> () -> Maybe (IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (IO ()) -> [String] -> Maybe (IO ())
forall a b. a -> b -> a
const Maybe (IO ())
forall a. Maybe a
Nothing) String
prog [String]
args