{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} module Futhark.CLI.Run (main) where import Control.Monad.Free.Church import Control.Exception import Data.Loc import Data.Maybe import qualified Data.Map as M import Control.Monad import Control.Monad.IO.Class import Control.Monad.Except import qualified Data.Text.IO as T import System.FilePath import System.Exit import System.Console.GetOpt import System.IO import Prelude import Language.Futhark import Language.Futhark.Parser hiding (EOF) import qualified Language.Futhark.TypeChecker as T import qualified Language.Futhark.Semantic as T import Futhark.Compiler import Futhark.Pipeline import Futhark.Util.Options import Futhark.Util (toPOSIX) import qualified Language.Futhark.Interpreter as I main :: String -> [String] -> IO () main :: String -> [String] -> IO () main = InterpreterConfig -> [FunOptDescr InterpreterConfig] -> String -> ([String] -> InterpreterConfig -> Maybe (IO ())) -> String -> [String] -> IO () forall cfg. cfg -> [FunOptDescr cfg] -> String -> ([String] -> cfg -> Maybe (IO ())) -> String -> [String] -> IO () mainWithOptions InterpreterConfig interpreterConfig [FunOptDescr InterpreterConfig] options String "options... program" [String] -> InterpreterConfig -> Maybe (IO ()) run where run :: [String] -> InterpreterConfig -> Maybe (IO ()) run [String prog] InterpreterConfig config = IO () -> Maybe (IO ()) forall a. a -> Maybe a Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ()) forall a b. (a -> b) -> a -> b $ InterpreterConfig -> String -> IO () interpret InterpreterConfig config String prog run [String] _ InterpreterConfig _ = Maybe (IO ()) forall a. Maybe a Nothing interpret :: InterpreterConfig -> FilePath -> IO () interpret :: InterpreterConfig -> String -> IO () interpret InterpreterConfig config String fp = do Either String (Env, Ctx) pr <- InterpreterConfig -> String -> IO (Either String (Env, Ctx)) newFutharkiState InterpreterConfig config String fp (Env tenv, Ctx ienv) <- case Either String (Env, Ctx) pr of Left String err -> do Handle -> String -> IO () hPutStrLn Handle stderr String err IO (Env, Ctx) forall a. IO a exitFailure Right (Env, Ctx) env -> (Env, Ctx) -> IO (Env, Ctx) forall (m :: * -> *) a. Monad m => a -> m a return (Env, Ctx) env let entry :: Name entry = InterpreterConfig -> Name interpreterEntryPoint InterpreterConfig config Either ParseError [Value] vr <- String -> Text -> Either ParseError [Value] parseValues String "stdin" (Text -> Either ParseError [Value]) -> IO Text -> IO (Either ParseError [Value]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> IO Text T.getContents [Value] inps <- case Either ParseError [Value] vr of Left ParseError err -> do Handle -> String -> IO () hPutStrLn Handle stderr (String -> IO ()) -> String -> IO () forall a b. (a -> b) -> a -> b $ String "Error when reading input: " String -> String -> String forall a. [a] -> [a] -> [a] ++ ParseError -> String forall a. Show a => a -> String show ParseError err IO [Value] forall a. IO a exitFailure Right [Value] vs -> [Value] -> IO [Value] forall (m :: * -> *) a. Monad m => a -> m a return [Value] vs (QualName VName fname, TypeBase () () ret) <- case (Namespace, Name) -> Map (Namespace, Name) (QualName VName) -> Maybe (QualName VName) forall k a. Ord k => k -> Map k a -> Maybe a M.lookup (Namespace T.Term, Name entry) (Map (Namespace, Name) (QualName VName) -> Maybe (QualName VName)) -> Map (Namespace, Name) (QualName VName) -> Maybe (QualName VName) forall a b. (a -> b) -> a -> b $ Env -> Map (Namespace, Name) (QualName VName) T.envNameMap Env tenv of Just QualName VName fname | Just (T.BoundV [TypeParam] _ StructType t) <- VName -> Map VName BoundV -> Maybe BoundV forall k a. Ord k => k -> Map k a -> Maybe a M.lookup (QualName VName -> VName forall vn. QualName vn -> vn qualLeaf QualName VName fname) (Map VName BoundV -> Maybe BoundV) -> Map VName BoundV -> Maybe BoundV forall a b. (a -> b) -> a -> b $ Env -> Map VName BoundV T.envVtable Env tenv -> (QualName VName, TypeBase () ()) -> IO (QualName VName, TypeBase () ()) forall (m :: * -> *) a. Monad m => a -> m a return (QualName VName fname, StructType -> TypeBase () () forall dim as. TypeBase dim as -> TypeBase () () toStructural (StructType -> TypeBase () ()) -> StructType -> TypeBase () () forall a b. (a -> b) -> a -> b $ ([StructType], StructType) -> StructType forall a b. (a, b) -> b snd (([StructType], StructType) -> StructType) -> ([StructType], StructType) -> StructType forall a b. (a -> b) -> a -> b $ StructType -> ([StructType], StructType) forall dim as. TypeBase dim as -> ([TypeBase dim as], TypeBase dim as) unfoldFunType StructType t) Maybe (QualName VName) _ -> do Handle -> String -> IO () hPutStrLn Handle stderr (String -> IO ()) -> String -> IO () forall a b. (a -> b) -> a -> b $ String "Invalid entry point: " String -> String -> String forall a. [a] -> [a] -> [a] ++ Name -> String forall a. Pretty a => a -> String pretty Name entry IO (QualName VName, TypeBase () ()) forall a. IO a exitFailure case Ctx -> VName -> [Value] -> Either String (F ExtOp Value) I.interpretFunction Ctx ienv (QualName VName -> VName forall vn. QualName vn -> vn qualLeaf QualName VName fname) [Value] inps of Left String err -> do Handle -> String -> IO () hPutStrLn Handle stderr String err IO () forall a. IO a exitFailure Right F ExtOp Value run -> do Either InterpreterError Value run' <- F ExtOp Value -> IO (Either InterpreterError Value) forall (m :: * -> *) a. MonadIO m => F ExtOp a -> m (Either InterpreterError a) runInterpreter' F ExtOp Value run case Either InterpreterError Value run' of Left InterpreterError err -> do Handle -> InterpreterError -> IO () forall a. Show a => Handle -> a -> IO () hPrint Handle stderr InterpreterError err IO () forall a. IO a exitFailure Right Value res -> case (Value -> Maybe [Value] I.fromTuple Value res, TypeBase () () -> Maybe [TypeBase () ()] forall dim as. TypeBase dim as -> Maybe [TypeBase dim as] isTupleRecord TypeBase () () ret) of (Just [Value] vs, Just [TypeBase () ()] ts) -> (Value -> TypeBase () () -> IO ()) -> [Value] -> [TypeBase () ()] -> IO () forall (m :: * -> *) a b c. Applicative m => (a -> b -> m c) -> [a] -> [b] -> m () zipWithM_ Value -> TypeBase () () -> IO () putValue [Value] vs [TypeBase () ()] ts (Maybe [Value], Maybe [TypeBase () ()]) _ -> Value -> TypeBase () () -> IO () putValue Value res TypeBase () () ret putValue :: I.Value -> TypeBase () () -> IO () putValue :: Value -> TypeBase () () -> IO () putValue Value v TypeBase () () t | Value -> Bool I.isEmptyArray Value v = String -> IO () putStrLn (String -> IO ()) -> String -> IO () forall a b. (a -> b) -> a -> b $ TypeBase () () -> Value -> String I.prettyEmptyArray TypeBase () () t Value v | Bool otherwise = String -> IO () putStrLn (String -> IO ()) -> String -> IO () forall a b. (a -> b) -> a -> b $ Value -> String forall a. Pretty a => a -> String pretty Value v data InterpreterConfig = InterpreterConfig { InterpreterConfig -> Name interpreterEntryPoint :: Name , InterpreterConfig -> Bool interpreterPrintWarnings :: Bool } interpreterConfig :: InterpreterConfig interpreterConfig :: InterpreterConfig interpreterConfig = Name -> Bool -> InterpreterConfig InterpreterConfig Name defaultEntryPoint Bool True options :: [FunOptDescr InterpreterConfig] options :: [FunOptDescr InterpreterConfig] options = [ String -> [String] -> ArgDescr (Either (IO ()) (InterpreterConfig -> InterpreterConfig)) -> String -> FunOptDescr InterpreterConfig forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a Option String "e" [String "entry-point"] ((String -> Either (IO ()) (InterpreterConfig -> InterpreterConfig)) -> String -> ArgDescr (Either (IO ()) (InterpreterConfig -> InterpreterConfig)) forall a. (String -> a) -> String -> ArgDescr a ReqArg (\String entry -> (InterpreterConfig -> InterpreterConfig) -> Either (IO ()) (InterpreterConfig -> InterpreterConfig) forall a b. b -> Either a b Right ((InterpreterConfig -> InterpreterConfig) -> Either (IO ()) (InterpreterConfig -> InterpreterConfig)) -> (InterpreterConfig -> InterpreterConfig) -> Either (IO ()) (InterpreterConfig -> InterpreterConfig) forall a b. (a -> b) -> a -> b $ \InterpreterConfig config -> InterpreterConfig config { interpreterEntryPoint :: Name interpreterEntryPoint = String -> Name nameFromString String entry }) String "NAME") String "The entry point to execute." , String -> [String] -> ArgDescr (Either (IO ()) (InterpreterConfig -> InterpreterConfig)) -> String -> FunOptDescr InterpreterConfig forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a Option String "w" [String "no-warnings"] (Either (IO ()) (InterpreterConfig -> InterpreterConfig) -> ArgDescr (Either (IO ()) (InterpreterConfig -> InterpreterConfig)) forall a. a -> ArgDescr a NoArg (Either (IO ()) (InterpreterConfig -> InterpreterConfig) -> ArgDescr (Either (IO ()) (InterpreterConfig -> InterpreterConfig))) -> Either (IO ()) (InterpreterConfig -> InterpreterConfig) -> ArgDescr (Either (IO ()) (InterpreterConfig -> InterpreterConfig)) forall a b. (a -> b) -> a -> b $ (InterpreterConfig -> InterpreterConfig) -> Either (IO ()) (InterpreterConfig -> InterpreterConfig) forall a b. b -> Either a b Right ((InterpreterConfig -> InterpreterConfig) -> Either (IO ()) (InterpreterConfig -> InterpreterConfig)) -> (InterpreterConfig -> InterpreterConfig) -> Either (IO ()) (InterpreterConfig -> InterpreterConfig) forall a b. (a -> b) -> a -> b $ \InterpreterConfig config -> InterpreterConfig config { interpreterPrintWarnings :: Bool interpreterPrintWarnings = Bool False }) String "Do not print warnings." ] newFutharkiState :: InterpreterConfig -> FilePath -> IO (Either String (T.Env, I.Ctx)) newFutharkiState :: InterpreterConfig -> String -> IO (Either String (Env, Ctx)) newFutharkiState InterpreterConfig cfg String file = ExceptT String IO (Env, Ctx) -> IO (Either String (Env, Ctx)) forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a) runExceptT (ExceptT String IO (Env, Ctx) -> IO (Either String (Env, Ctx))) -> ExceptT String IO (Env, Ctx) -> IO (Either String (Env, Ctx)) forall a b. (a -> b) -> a -> b $ do (Warnings ws, Imports imports, VNameSource src) <- (CompilerError -> String) -> Either CompilerError (Warnings, Imports, VNameSource) -> ExceptT String IO (Warnings, Imports, VNameSource) forall err a. (err -> String) -> Either err a -> ExceptT String IO a badOnLeft CompilerError -> String forall a. Show a => a -> String show (Either CompilerError (Warnings, Imports, VNameSource) -> ExceptT String IO (Warnings, Imports, VNameSource)) -> ExceptT String IO (Either CompilerError (Warnings, Imports, VNameSource)) -> ExceptT String IO (Warnings, Imports, VNameSource) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO (Either CompilerError (Warnings, Imports, VNameSource)) -> ExceptT String IO (Either CompilerError (Warnings, Imports, VNameSource)) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (ExceptT CompilerError IO (Warnings, Imports, VNameSource) -> IO (Either CompilerError (Warnings, Imports, VNameSource)) forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a) runExceptT (String -> ExceptT CompilerError IO (Warnings, Imports, VNameSource) forall (m :: * -> *). (MonadError CompilerError m, MonadIO m) => String -> m (Warnings, Imports, VNameSource) readProgram String file) IO (Either CompilerError (Warnings, Imports, VNameSource)) -> (IOException -> IO (Either CompilerError (Warnings, Imports, VNameSource))) -> IO (Either CompilerError (Warnings, Imports, VNameSource)) forall e a. Exception e => IO a -> (e -> IO a) -> IO a `catch` \(IOException err::IOException) -> Either CompilerError (Warnings, Imports, VNameSource) -> IO (Either CompilerError (Warnings, Imports, VNameSource)) forall (m :: * -> *) a. Monad m => a -> m a return (String -> Either CompilerError (Warnings, Imports, VNameSource) forall (m :: * -> *) a. MonadError CompilerError m => String -> m a externalErrorS (IOException -> String forall a. Show a => a -> String show IOException err))) Bool -> ExceptT String IO () -> ExceptT String IO () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (InterpreterConfig -> Bool interpreterPrintWarnings InterpreterConfig cfg) (ExceptT String IO () -> ExceptT String IO ()) -> ExceptT String IO () -> ExceptT String IO () forall a b. (a -> b) -> a -> b $ IO () -> ExceptT String IO () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO () forall a b. (a -> b) -> a -> b $ Handle -> Warnings -> IO () forall a. Show a => Handle -> a -> IO () hPrint Handle stderr Warnings ws let imp :: ImportName imp = String -> ImportName T.mkInitialImport String "." Ctx ienv1 <- (Ctx -> (String, Prog) -> ExceptT String IO Ctx) -> Ctx -> [(String, Prog)] -> ExceptT String IO Ctx forall (t :: * -> *) (m :: * -> *) b a. (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b foldM (\Ctx ctx -> (InterpreterError -> String) -> Either InterpreterError Ctx -> ExceptT String IO Ctx forall err a. (err -> String) -> Either err a -> ExceptT String IO a badOnLeft InterpreterError -> String forall a. Show a => a -> String show (Either InterpreterError Ctx -> ExceptT String IO Ctx) -> ((String, Prog) -> ExceptT String IO (Either InterpreterError Ctx)) -> (String, Prog) -> ExceptT String IO Ctx forall (m :: * -> *) b c a. Monad m => (b -> m c) -> (a -> m b) -> a -> m c <=< F ExtOp Ctx -> ExceptT String IO (Either InterpreterError Ctx) forall (m :: * -> *) a. MonadIO m => F ExtOp a -> m (Either InterpreterError a) runInterpreter' (F ExtOp Ctx -> ExceptT String IO (Either InterpreterError Ctx)) -> ((String, Prog) -> F ExtOp Ctx) -> (String, Prog) -> ExceptT String IO (Either InterpreterError Ctx) forall b c a. (b -> c) -> (a -> b) -> a -> c . Ctx -> (String, Prog) -> F ExtOp Ctx I.interpretImport Ctx ctx) Ctx I.initialCtx ([(String, Prog)] -> ExceptT String IO Ctx) -> [(String, Prog)] -> ExceptT String IO Ctx forall a b. (a -> b) -> a -> b $ ((String, FileModule) -> (String, Prog)) -> Imports -> [(String, Prog)] forall a b. (a -> b) -> [a] -> [b] map ((FileModule -> Prog) -> (String, FileModule) -> (String, Prog) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap FileModule -> Prog fileProg) Imports imports (Env tenv1, Dec d1, VNameSource src') <- (TypeError -> String) -> Either TypeError (Env, Dec, VNameSource) -> ExceptT String IO (Env, Dec, VNameSource) forall err a. (err -> String) -> Either err a -> ExceptT String IO a badOnLeft TypeError -> String forall a. Pretty a => a -> String pretty (Either TypeError (Env, Dec, VNameSource) -> ExceptT String IO (Env, Dec, VNameSource)) -> Either TypeError (Env, Dec, VNameSource) -> ExceptT String IO (Env, Dec, VNameSource) forall a b. (a -> b) -> a -> b $ Imports -> VNameSource -> Env -> ImportName -> UncheckedDec -> Either TypeError (Env, Dec, VNameSource) T.checkDec Imports imports VNameSource src Env T.initialEnv ImportName imp (UncheckedDec -> Either TypeError (Env, Dec, VNameSource)) -> UncheckedDec -> Either TypeError (Env, Dec, VNameSource) forall a b. (a -> b) -> a -> b $ String -> UncheckedDec mkOpen String "/prelude/prelude" (Env tenv2, Dec d2, VNameSource _) <- (TypeError -> String) -> Either TypeError (Env, Dec, VNameSource) -> ExceptT String IO (Env, Dec, VNameSource) forall err a. (err -> String) -> Either err a -> ExceptT String IO a badOnLeft TypeError -> String forall a. Pretty a => a -> String pretty (Either TypeError (Env, Dec, VNameSource) -> ExceptT String IO (Env, Dec, VNameSource)) -> Either TypeError (Env, Dec, VNameSource) -> ExceptT String IO (Env, Dec, VNameSource) forall a b. (a -> b) -> a -> b $ Imports -> VNameSource -> Env -> ImportName -> UncheckedDec -> Either TypeError (Env, Dec, VNameSource) T.checkDec Imports imports VNameSource src' Env tenv1 ImportName imp (UncheckedDec -> Either TypeError (Env, Dec, VNameSource)) -> UncheckedDec -> Either TypeError (Env, Dec, VNameSource) forall a b. (a -> b) -> a -> b $ String -> UncheckedDec mkOpen (String -> UncheckedDec) -> String -> UncheckedDec forall a b. (a -> b) -> a -> b $ String -> String toPOSIX (String -> String) -> String -> String forall a b. (a -> b) -> a -> b $ String -> String dropExtension String file Ctx ienv2 <- (InterpreterError -> String) -> Either InterpreterError Ctx -> ExceptT String IO Ctx forall err a. (err -> String) -> Either err a -> ExceptT String IO a badOnLeft InterpreterError -> String forall a. Show a => a -> String show (Either InterpreterError Ctx -> ExceptT String IO Ctx) -> ExceptT String IO (Either InterpreterError Ctx) -> ExceptT String IO Ctx forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< F ExtOp Ctx -> ExceptT String IO (Either InterpreterError Ctx) forall (m :: * -> *) a. MonadIO m => F ExtOp a -> m (Either InterpreterError a) runInterpreter' (Ctx -> Dec -> F ExtOp Ctx I.interpretDec Ctx ienv1 Dec d1) Ctx ienv3 <- (InterpreterError -> String) -> Either InterpreterError Ctx -> ExceptT String IO Ctx forall err a. (err -> String) -> Either err a -> ExceptT String IO a badOnLeft InterpreterError -> String forall a. Show a => a -> String show (Either InterpreterError Ctx -> ExceptT String IO Ctx) -> ExceptT String IO (Either InterpreterError Ctx) -> ExceptT String IO Ctx forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< F ExtOp Ctx -> ExceptT String IO (Either InterpreterError Ctx) forall (m :: * -> *) a. MonadIO m => F ExtOp a -> m (Either InterpreterError a) runInterpreter' (Ctx -> Dec -> F ExtOp Ctx I.interpretDec Ctx ienv2 Dec d2) (Env, Ctx) -> ExceptT String IO (Env, Ctx) forall (m :: * -> *) a. Monad m => a -> m a return (Env tenv2, Ctx ienv3) where badOnLeft :: (err -> String) -> Either err a -> ExceptT String IO a badOnLeft :: (err -> String) -> Either err a -> ExceptT String IO a badOnLeft err -> String _ (Right a x) = a -> ExceptT String IO a forall (m :: * -> *) a. Monad m => a -> m a return a x badOnLeft err -> String p (Left err err) = String -> ExceptT String IO a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (String -> ExceptT String IO a) -> String -> ExceptT String IO a forall a b. (a -> b) -> a -> b $ err -> String p err err mkOpen :: FilePath -> UncheckedDec mkOpen :: String -> UncheckedDec mkOpen String f = ModExpBase NoInfo Name -> SrcLoc -> UncheckedDec forall (f :: * -> *) vn. ModExpBase f vn -> SrcLoc -> DecBase f vn OpenDec (String -> NoInfo String -> SrcLoc -> ModExpBase NoInfo Name forall (f :: * -> *) vn. String -> f String -> SrcLoc -> ModExpBase f vn ModImport String f NoInfo String forall a. NoInfo a NoInfo SrcLoc forall a. IsLocation a => a noLoc) SrcLoc forall a. IsLocation a => a noLoc runInterpreter' :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a) runInterpreter' :: F ExtOp a -> m (Either InterpreterError a) runInterpreter' F ExtOp a m = F ExtOp a -> (a -> m (Either InterpreterError a)) -> (ExtOp (m (Either InterpreterError a)) -> m (Either InterpreterError a)) -> m (Either InterpreterError a) forall (f :: * -> *) a. F f a -> forall r. (a -> r) -> (f r -> r) -> r runF F ExtOp a m (Either InterpreterError a -> m (Either InterpreterError a) forall (m :: * -> *) a. Monad m => a -> m a return (Either InterpreterError a -> m (Either InterpreterError a)) -> (a -> Either InterpreterError a) -> a -> m (Either InterpreterError a) forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> Either InterpreterError a forall a b. b -> Either a b Right) ExtOp (m (Either InterpreterError a)) -> m (Either InterpreterError a) forall (m :: * -> *) b. MonadIO m => ExtOp (m (Either InterpreterError b)) -> m (Either InterpreterError b) intOp where intOp :: ExtOp (m (Either InterpreterError b)) -> m (Either InterpreterError b) intOp (I.ExtOpError InterpreterError err) = Either InterpreterError b -> m (Either InterpreterError b) forall (m :: * -> *) a. Monad m => a -> m a return (Either InterpreterError b -> m (Either InterpreterError b)) -> Either InterpreterError b -> m (Either InterpreterError b) forall a b. (a -> b) -> a -> b $ InterpreterError -> Either InterpreterError b forall a b. a -> Either a b Left InterpreterError err intOp (I.ExtOpTrace Loc w String v m (Either InterpreterError b) c) = do IO () -> m () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> m ()) -> IO () -> m () forall a b. (a -> b) -> a -> b $ String -> IO () putStrLn (String -> IO ()) -> String -> IO () forall a b. (a -> b) -> a -> b $ String "Trace at " String -> String -> String forall a. [a] -> [a] -> [a] ++ Loc -> String forall a. Located a => a -> String locStr Loc w String -> String -> String forall a. [a] -> [a] -> [a] ++ String ": " String -> String -> String forall a. [a] -> [a] -> [a] ++ String v m (Either InterpreterError b) c intOp (I.ExtOpBreak NonEmpty StackFrame _ m (Either InterpreterError b) c) = m (Either InterpreterError b) c