-- | Various small subcommands that are too simple to deserve their own file.
module Futhark.CLI.Misc
  ( mainImports,
    mainHash,
    mainDataget,
    mainCheckSyntax,
    mainThanks,
    mainTokens,
  )
where

import Control.Monad
import Control.Monad.State
import Data.ByteString.Lazy qualified as BS
import Data.Function (on)
import Data.List (nubBy)
import Data.Loc (L (..), startPos)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Futhark.Compiler
import Futhark.Test
import Futhark.Util (hashText, interactWithFileSafely)
import Futhark.Util.Options
import Futhark.Util.Pretty (prettyTextOneLine)
import Language.Futhark.Parser.Lexer (scanTokensText)
import Language.Futhark.Prop (isBuiltin)
import Language.Futhark.Semantic (includeToString)
import System.Environment (getExecutablePath)
import System.Exit
import System.FilePath
import System.IO
import System.Random

-- | @futhark imports@
mainImports :: String -> [String] -> IO ()
mainImports :: String -> [String] -> IO ()
mainImports = ()
-> [FunOptDescr ()]
-> String
-> ([String] -> () -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions () [] String
"program" (([String] -> () -> Maybe (IO ())) -> String -> [String] -> IO ())
-> ([String] -> () -> Maybe (IO ())) -> String -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ \[String]
args () ->
  case [String]
args of
    [String
file] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ do
      (Warnings
_, Imports
prog_imports, VNameSource
_) <- String -> IO (Warnings, Imports, VNameSource)
forall (m :: * -> *).
MonadIO m =>
String -> m (Warnings, Imports, VNameSource)
readProgramOrDie String
file
      IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> ([String] -> IO ()) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStr (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".fut") ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isBuiltin) ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
        ((ImportName, FileModule) -> String) -> Imports -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ImportName -> String
includeToString (ImportName -> String)
-> ((ImportName, FileModule) -> ImportName)
-> (ImportName, FileModule)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImportName, FileModule) -> ImportName
forall a b. (a, b) -> a
fst) Imports
prog_imports
    [String]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing

-- | @futhark hash@
mainHash :: String -> [String] -> IO ()
mainHash :: String -> [String] -> IO ()
mainHash = ()
-> [FunOptDescr ()]
-> String
-> ([String] -> () -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions () [] String
"program" (([String] -> () -> Maybe (IO ())) -> String -> [String] -> IO ())
-> ([String] -> () -> Maybe (IO ())) -> String -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ \[String]
args () ->
  case [String]
args of
    [String
file] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ do
      [(String, UncheckedProg)]
prog <- ((String, UncheckedProg) -> Bool)
-> [(String, UncheckedProg)] -> [(String, UncheckedProg)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((String, UncheckedProg) -> Bool)
-> (String, UncheckedProg)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isBuiltin (String -> Bool)
-> ((String, UncheckedProg) -> String)
-> (String, UncheckedProg)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, UncheckedProg) -> String
forall a b. (a, b) -> a
fst) ([(String, UncheckedProg)] -> [(String, UncheckedProg)])
-> IO [(String, UncheckedProg)] -> IO [(String, UncheckedProg)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [(String, UncheckedProg)]
forall (m :: * -> *).
MonadIO m =>
String -> m [(String, UncheckedProg)]
readUntypedProgramOrDie String
file
      -- The 'map snd' is an attempt to get rid of the file names so
      -- they won't affect the hashing.
      IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
hashText (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [UncheckedProg] -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine ([UncheckedProg] -> Text) -> [UncheckedProg] -> Text
forall a b. (a -> b) -> a -> b
$ ((String, UncheckedProg) -> UncheckedProg)
-> [(String, UncheckedProg)] -> [UncheckedProg]
forall a b. (a -> b) -> [a] -> [b]
map (String, UncheckedProg) -> UncheckedProg
forall a b. (a, b) -> b
snd [(String, UncheckedProg)]
prog
    [String]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing

-- | @futhark dataget@
mainDataget :: String -> [String] -> IO ()
mainDataget :: String -> [String] -> IO ()
mainDataget = ()
-> [FunOptDescr ()]
-> String
-> ([String] -> () -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions () [] String
"program dataset" (([String] -> () -> Maybe (IO ())) -> String -> [String] -> IO ())
-> ([String] -> () -> Maybe (IO ())) -> String -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ \[String]
args () ->
  case [String]
args of
    [String
file, String
dataset] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
dataget String
file (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
dataset
    [String]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing
  where
    dataget :: String -> Text -> IO ()
dataget String
prog Text
dataset = do
      let dir :: String
dir = String -> String
takeDirectory String
prog

      [TestRun]
runs <- ProgramTest -> [TestRun]
testSpecRuns (ProgramTest -> [TestRun]) -> IO ProgramTest -> IO [TestRun]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ProgramTest
testSpecFromProgramOrDie String
prog

      let exact :: [TestRun]
exact = (TestRun -> Bool) -> [TestRun] -> [TestRun]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text
dataset ==) (Text -> Bool) -> (TestRun -> Text) -> TestRun -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestRun -> Text
runDescription) [TestRun]
runs
          infixes :: [TestRun]
infixes = (TestRun -> Bool) -> [TestRun] -> [TestRun]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text
dataset `T.isInfixOf`) (Text -> Bool) -> (TestRun -> Text) -> TestRun -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestRun -> Text
runDescription) [TestRun]
runs

      FutharkExe
futhark <- String -> FutharkExe
FutharkExe (String -> FutharkExe) -> IO String -> IO FutharkExe
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getExecutablePath

      case (TestRun -> TestRun -> Bool) -> [TestRun] -> [TestRun]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Text -> Text -> Bool)
-> (TestRun -> Text) -> TestRun -> TestRun -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TestRun -> Text
runDescription) ([TestRun] -> [TestRun]) -> [TestRun] -> [TestRun]
forall a b. (a -> b) -> a -> b
$
        if [TestRun] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestRun]
exact then [TestRun]
infixes else [TestRun]
exact of
        [TestRun
x] -> ByteString -> IO ()
BS.putStr (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FutharkExe -> String -> Values -> IO ByteString
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
FutharkExe -> String -> Values -> m ByteString
getValuesBS FutharkExe
futhark String
dir (TestRun -> Values
runInput TestRun
x)
        [] -> do
          Handle -> Text -> IO ()
T.hPutStr Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"No dataset '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dataset Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'.\n"
          Handle -> Text -> IO ()
T.hPutStr Handle
stderr Text
"Available datasets:\n"
          (TestRun -> IO ()) -> [TestRun] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> (TestRun -> Text) -> TestRun -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"  " <>) (Text -> Text) -> (TestRun -> Text) -> TestRun -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestRun -> Text
runDescription) [TestRun]
runs
          IO ()
forall a. IO a
exitFailure
        [TestRun]
runs' -> do
          Handle -> Text -> IO ()
T.hPutStr Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Dataset '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dataset Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' ambiguous:\n"
          (TestRun -> IO ()) -> [TestRun] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> (TestRun -> Text) -> TestRun -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"  " <>) (Text -> Text) -> (TestRun -> Text) -> TestRun -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestRun -> Text
runDescription) [TestRun]
runs'
          IO ()
forall a. IO a
exitFailure

    testSpecRuns :: ProgramTest -> [TestRun]
testSpecRuns = TestAction -> [TestRun]
testActionRuns (TestAction -> [TestRun])
-> (ProgramTest -> TestAction) -> ProgramTest -> [TestRun]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramTest -> TestAction
testAction
    testActionRuns :: TestAction -> [TestRun]
testActionRuns CompileTimeFailure {} = []
    testActionRuns (RunCases [InputOutputs]
ios [StructureTest]
_ [WarningTest]
_) = (InputOutputs -> [TestRun]) -> [InputOutputs] -> [TestRun]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap InputOutputs -> [TestRun]
iosTestRuns [InputOutputs]
ios

-- | @futhark check-syntax@
mainCheckSyntax :: String -> [String] -> IO ()
mainCheckSyntax :: String -> [String] -> IO ()
mainCheckSyntax = ()
-> [FunOptDescr ()]
-> String
-> ([String] -> () -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions () [] String
"program" (([String] -> () -> Maybe (IO ())) -> String -> [String] -> IO ())
-> ([String] -> () -> Maybe (IO ())) -> String -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ \[String]
args () ->
  case [String]
args of
    [String
file] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ IO [(String, UncheckedProg)] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [(String, UncheckedProg)] -> IO ())
-> IO [(String, UncheckedProg)] -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO [(String, UncheckedProg)]
forall (m :: * -> *).
MonadIO m =>
String -> m [(String, UncheckedProg)]
readUntypedProgramOrDie String
file
    [String]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing

-- | @futhark thanks@
mainThanks :: String -> [String] -> IO ()
mainThanks :: String -> [String] -> IO ()
mainThanks = ()
-> [FunOptDescr ()]
-> String
-> ([String] -> () -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions () [] String
"" (([String] -> () -> Maybe (IO ())) -> String -> [String] -> IO ())
-> ([String] -> () -> Maybe (IO ())) -> String -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ \[String]
args () ->
  case [String]
args of
    [] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ do
      Int
i <- (Int, Int) -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
0, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String]
responses [String] -> Int -> String
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
    [String]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing
  where
    n :: Int
n = [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
responses
    responses :: [String]
responses =
      [ String
"You're welcome!",
        String
"Tell all your friends about Futhark!",
        String
"Likewise!",
        String
"And thank you in return for trying the language!",
        String
"It's our pleasure!",
        String
"Have fun with Futhark!"
      ]

-- | @futhark tokens@
mainTokens :: String -> [String] -> IO ()
mainTokens :: String -> [String] -> IO ()
mainTokens = ()
-> [FunOptDescr ()]
-> String
-> ([String] -> () -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions () [] String
"program" (([String] -> () -> Maybe (IO ())) -> String -> [String] -> IO ())
-> ([String] -> () -> Maybe (IO ())) -> String -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ \[String]
args () ->
  case [String]
args of
    [String
file] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ do
      Maybe (Either String (Either LexerError ([L Token], Pos)))
res <- IO (Either LexerError ([L Token], Pos))
-> IO (Maybe (Either String (Either LexerError ([L Token], Pos))))
forall a. IO a -> IO (Maybe (Either String a))
interactWithFileSafely (Pos -> Text -> Either LexerError ([L Token], Pos)
scanTokensText (String -> Pos
startPos String
file) (Text -> Either LexerError ([L Token], Pos))
-> IO Text -> IO (Either LexerError ([L Token], Pos))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
T.readFile String
file)
      case Maybe (Either String (Either LexerError ([L Token], Pos)))
res of
        Maybe (Either String (Either LexerError ([L Token], Pos)))
Nothing -> do
          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
file String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": file not found."
          ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
        Just (Left String
e) -> do
          Handle -> String -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr String
e
          ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
        Just (Right (Left LexerError
e)) -> do
          Handle -> LexerError -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr LexerError
e
          ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
        Just (Right (Right ([L Token]
tokens, Pos
_))) ->
          (L Token -> IO ()) -> [L Token] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ L Token -> IO ()
forall {a}. Show a => L a -> IO ()
printToken [L Token]
tokens
    [String]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing
  where
    printToken :: L a -> IO ()
printToken (L Loc
_ a
token) =
      a -> IO ()
forall a. Show a => a -> IO ()
print a
token