-- | 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.State
import Data.ByteString.Lazy qualified as BS
import Data.Function (on)
import Data.List (isInfixOf, nubBy)
import Data.Loc (L (..), startPos)
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 (scanTokens)
import Language.Futhark.Prop (isBuiltin)
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 = forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions () [] String
"program" forall a b. (a -> b) -> a -> b
$ \[String]
args () ->
  case [String]
args of
    [String
file] -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
      (Warnings
_, Imports
prog_imports, VNameSource
_) <- forall (m :: * -> *).
MonadIO m =>
String -> m (Warnings, Imports, VNameSource)
readProgramOrDie String
file
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [a] -> [a]
++ String
".fut") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isBuiltin) forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst Imports
prog_imports
    [String]
_ -> forall a. Maybe a
Nothing

-- | @futhark hash@
mainHash :: String -> [String] -> IO ()
mainHash :: String -> [String] -> IO ()
mainHash = forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions () [] String
"program" forall a b. (a -> b) -> a -> b
$ \[String]
args () ->
  case [String]
args of
    [String
file] -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
      [(String, UncheckedProg)]
prog <- forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isBuiltin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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.
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Text -> Text
hashText forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
prettyTextOneLine forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(String, UncheckedProg)]
prog
    [String]
_ -> forall a. Maybe a
Nothing

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

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

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

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

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

    testSpecRuns :: ProgramTest -> [TestRun]
testSpecRuns = TestAction -> [TestRun]
testActionRuns forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramTest -> TestAction
testAction
    testActionRuns :: TestAction -> [TestRun]
testActionRuns CompileTimeFailure {} = []
    testActionRuns (RunCases [InputOutputs]
ios [StructureTest]
_ [WarningTest]
_) = 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 = forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions () [] String
"program" forall a b. (a -> b) -> a -> b
$ \[String]
args () ->
  case [String]
args of
    [String
file] -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
String -> m [(String, UncheckedProg)]
readUntypedProgramOrDie String
file
    [String]
_ -> forall a. Maybe a
Nothing

-- | @futhark thanks@
mainThanks :: String -> [String] -> IO ()
mainThanks :: String -> [String] -> IO ()
mainThanks = forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions () [] String
"" forall a b. (a -> b) -> a -> b
$ \[String]
args () ->
  case [String]
args of
    [] -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
      Int
i <- forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
0, Int
n forall a. Num a => a -> a -> a
- Int
1)
      String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [String]
responses forall a. [a] -> Int -> a
!! Int
i
    [String]
_ -> forall a. Maybe a
Nothing
  where
    n :: Int
n = 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!"
      ]

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