<commit_before>{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuasiQuotes #-}
module Main (main) where

import Control.Exception
import Data.Char
import Data.List
import Data.Loc
import Data.Maybe
import Data.Version
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.State
import Control.Monad.Except
import Data.Semigroup ((<>))
import qualified Data.Text as T
import qualified Data.Text.IO as T
import NeatInterpolation (text)
import System.FilePath
import System.Exit
import System.Console.GetOpt
import qualified System.Console.Haskeline as Haskeline

import Language.Futhark
import Language.Futhark.Parser
import Language.Futhark.TypeChecker
import Language.Futhark.Semantic
import Futhark.MonadFreshNames
import Futhark.Interpreter
import Futhark.Version
import Futhark.Passes
import Futhark.Compiler
import Futhark.Pipeline
import Futhark.Internalise
import Futhark.Util.Options
import Language.Futhark.Futlib.Prelude

banner :: String
banner = unlines [
  "|// |\\    |   |\\  |\\   /",
  "|/  | \\   |\\  |\\  |/  /",
  "|   |  \\  |/  |   |\\  \\",
  "|   |   \\ |   |   | \\  \\"
  ]

main :: IO ()
main = reportingIOErrors $
       mainWithOptions interpreterConfig options run
  where run [prog] config = Just $ interpret config prog
        run []     _      = Just repl
        run _      _      = Nothing

repl :: IO ()
repl = do
  putStr banner
  putStrLn $ "Version " ++ showVersion version ++ "."
  putStrLn "Copyright (C) DIKU, University of Copenhagen, released under the ISC license."
  putStrLn ""
  putStrLn "Run :help for a list of commands."
  putStrLn ""
  s <- newInterpreterState
  Haskeline.runInputT Haskeline.defaultSettings
    (evalStateT (forever readEvalPrint) s)

interpret :: InterpreterConfig -> FilePath -> IO ()
interpret config =
  runCompilerOnProgram newFutharkConfig preludeBasis standardPipeline $
  interpretAction' $ interpreterEntryPoint config

newtype InterpreterConfig = InterpreterConfig { interpreterEntryPoint :: Name }

interpreterConfig :: InterpreterConfig
interpreterConfig = InterpreterConfig defaultEntryPoint

options :: [FunOptDescr InterpreterConfig]
options = [ Option "e" ["entry-point"]
          (ReqArg (\entry -> Right $ \config ->
                      config { interpreterEntryPoint = nameFromString entry })
           "NAME")
            "The entry point to execute."
          ]

data InterpreterState =
  InterpreterState { interpImports :: Imports
                   , interpDecs :: [UncheckedDec]
                   , interpNameSource :: VNameSource
                   , interpCount :: Int
                   }

newInterpreterState :: IO InterpreterState
newInterpreterState = do
  res <- runExceptT $ readLibrary preludeBasis []
  case res of
    Right (_, imports, src) ->
      return InterpreterState { interpImports = imports
                              , interpDecs = map mkOpen $ basisRoots preludeBasis
                              , interpNameSource = src
                              , interpCount = 0
                              }
    Left err -> do
      putStrLn "Error when initialising interpreter state:"
      print err
      exitFailure

getPrompt :: FutharkiM String
getPrompt = do
  i <- gets interpCount
  return $ "[" ++ show i ++ "]"

mkOpen :: FilePath -> UncheckedDec
mkOpen f = OpenDec (ModImport f NoInfo noLoc) [] NoInfo noLoc

type FutharkiM = StateT InterpreterState (Haskeline.InputT IO)

readEvalPrint :: FutharkiM ()
readEvalPrint = do
  i <- gets interpCount
  prompt <- getPrompt
  modify $ \s -> s { interpCount = i + 1 }
  line <- inputLine $ "[" ++ show i ++ "]> "
  case T.uncons line of
    Just (':', command) -> do
      let (cmdname, rest) = T.break isSpace command
          arg = T.dropWhileEnd isSpace $ T.dropWhile isSpace rest
      case filter ((cmdname `T.isPrefixOf`) . fst) commands of
        [] -> liftIO $ T.putStrLn $ "Unknown command '" <> cmdname <> "'"
        [(_, (cmdf, _))] -> cmdf arg
        matches -> liftIO $ T.putStrLn $ "Ambiguous command; could be one of " <>
                   mconcat (intersperse ", " (map fst matches))
    _ -> do
      -- Read a declaration or expression.
      maybe_dec_or_e <- parseDecOrExpIncrM (inputLine "  ") prompt line

      case maybe_dec_or_e of
        Left err -> liftIO $ print err
        Right (Left d) -> onDec d
        Right (Right e) -> onExp e
  where inputLine prompt = do
          inp <- lift $ Haskeline.getInputLine prompt
          case inp of
            Just s -> return $ T.pack s
            Nothing -> liftIO $ do putStrLn "Leaving futharki."
                                   exitSuccess

onDec :: UncheckedDec -> FutharkiM ()
onDec d = do
  prompt <- getPrompt
  decs <- gets interpDecs
  -- See first if it type checks.
  let decs' = decs ++ [d]
      prog = Prog Nothing decs'
      include = mkInitialImport prompt
  -- We have to read in any new imports done by the declaration.
  basis <- curBasis
  res <- runExceptT $ readImports basis $
         map (uncurry $ mkImportFrom include) $
         progImports $ Prog Nothing [d]
  case res of
    Left err -> liftIO $ print err
    Right (_, imports, src) ->
      case checkProg imports src include prog of
        Left err -> liftIO $ print err
        Right (fm, _, src') -> do
          liftIO $ mapM_ putStrLn $ mapMaybe reportDec $ progDecs $ fileProg fm
          modify $ \s ->
            s { interpDecs = decs ++ [mkOpen prompt]
              , interpNameSource = src'
              , interpImports = imports ++ [(includeToString include, fm)] }

  where curBasis = do
          imports <- gets interpImports
          src <- gets interpNameSource
          return $ Basis { basisImports = imports
                         , basisNameSource = src
                         , basisRoots = basisRoots preludeBasis }

        reportDec (ValDec vb) =
          Just $ baseString (valBindName vb) <> " : " <>
          pretty (unInfo $ valBindRetType vb)
        reportDec (TypeDec tb) =
          Just $ pretty tb
        reportDec _ = Nothing

onExp :: UncheckedExp -> FutharkiM ()
onExp e = do
  imports <- gets interpImports
  decs <- gets interpDecs
  src <- gets interpNameSource<commit_msg>Also remember the type parameters here.<commit_after>{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuasiQuotes #-}
module Main (main) where

import Control.Exception
import Data.Char
import Data.List
import Data.Loc
import Data.Maybe
import Data.Version
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.State
import Control.Monad.Except
import Data.Semigroup ((<>))
import qualified Data.Text as T
import qualified Data.Text.IO as T
import NeatInterpolation (text)
import System.FilePath
import System.Exit
import System.Console.GetOpt
import qualified System.Console.Haskeline as Haskeline

import Language.Futhark
import Language.Futhark.Parser
import Language.Futhark.TypeChecker
import Language.Futhark.Semantic
import Futhark.MonadFreshNames
import Futhark.Interpreter
import Futhark.Version
import Futhark.Passes
import Futhark.Compiler
import Futhark.Pipeline
import Futhark.Internalise
import Futhark.Util.Options
import Language.Futhark.Futlib.Prelude

banner :: String
banner = unlines [
  "|// |\\    |   |\\  |\\   /",
  "|/  | \\   |\\  |\\  |/  /",
  "|   |  \\  |/  |   |\\  \\",
  "|   |   \\ |   |   | \\  \\"
  ]

main :: IO ()
main = reportingIOErrors $
       mainWithOptions interpreterConfig options run
  where run [prog] config = Just $ interpret config prog
        run []     _      = Just repl
        run _      _      = Nothing

repl :: IO ()
repl = do
  putStr banner
  putStrLn $ "Version " ++ showVersion version ++ "."
  putStrLn "Copyright (C) DIKU, University of Copenhagen, released under the ISC license."
  putStrLn ""
  putStrLn "Run :help for a list of commands."
  putStrLn ""
  s <- newInterpreterState
  Haskeline.runInputT Haskeline.defaultSettings
    (evalStateT (forever readEvalPrint) s)

interpret :: InterpreterConfig -> FilePath -> IO ()
interpret config =
  runCompilerOnProgram newFutharkConfig preludeBasis standardPipeline $
  interpretAction' $ interpreterEntryPoint config

newtype InterpreterConfig = InterpreterConfig { interpreterEntryPoint :: Name }

interpreterConfig :: InterpreterConfig
interpreterConfig = InterpreterConfig defaultEntryPoint

options :: [FunOptDescr InterpreterConfig]
options = [ Option "e" ["entry-point"]
          (ReqArg (\entry -> Right $ \config ->
                      config { interpreterEntryPoint = nameFromString entry })
           "NAME")
            "The entry point to execute."
          ]

data InterpreterState =
  InterpreterState { interpImports :: Imports
                   , interpDecs :: [UncheckedDec]
                   , interpNameSource :: VNameSource
                   , interpCount :: Int
                   }

newInterpreterState :: IO InterpreterState
newInterpreterState = do
  res <- runExceptT $ readLibrary preludeBasis []
  case res of
    Right (_, imports, src) ->
      return InterpreterState { interpImports = imports
                              , interpDecs = map mkOpen $ basisRoots preludeBasis
                              , interpNameSource = src
                              , interpCount = 0
                              }
    Left err -> do
      putStrLn "Error when initialising interpreter state:"
      print err
      exitFailure

getPrompt :: FutharkiM String
getPrompt = do
  i <- gets interpCount
  return $ "[" ++ show i ++ "]"

mkOpen :: FilePath -> UncheckedDec
mkOpen f = OpenDec (ModImport f NoInfo noLoc) [] NoInfo noLoc

type FutharkiM = StateT InterpreterState (Haskeline.InputT IO)

readEvalPrint :: FutharkiM ()
readEvalPrint = do
  i <- gets interpCount
  prompt <- getPrompt
  modify $ \s -> s { interpCount = i + 1 }
  line <- inputLine $ "[" ++ show i ++ "]> "
  case T.uncons line of
    Just (':', command) -> do
      let (cmdname, rest) = T.break isSpace command
          arg = T.dropWhileEnd isSpace $ T.dropWhile isSpace rest
      case filter ((cmdname `T.isPrefixOf`) . fst) commands of
        [] -> liftIO $ T.putStrLn $ "Unknown command '" <> cmdname <> "'"
        [(_, (cmdf, _))] -> cmdf arg
        matches -> liftIO $ T.putStrLn $ "Ambiguous command; could be one of " <>
                   mconcat (intersperse ", " (map fst matches))
    _ -> do
      -- Read a declaration or expression.
      maybe_dec_or_e <- parseDecOrExpIncrM (inputLine "  ") prompt line

      case maybe_dec_or_e of
        Left err -> liftIO $ print err
        Right (Left d) -> onDec d
        Right (Right e) -> onExp e
  where inputLine prompt = do
          inp <- lift $ Haskeline.getInputLine prompt
          case inp of
            Just s -> return $ T.pack s
            Nothing -> liftIO $ do putStrLn "Leaving futharki."
                                   exitSuccess

onDec :: UncheckedDec -> FutharkiM ()
onDec d = do
  prompt <- getPrompt
  decs <- gets interpDecs
  -- See first if it type checks.
  let decs' = decs ++ [d]
      prog = Prog Nothing decs'
      include = mkInitialImport prompt
  -- We have to read in any new imports done by the declaration.
  basis <- curBasis
  res <- runExceptT $ readImports basis $
         map (uncurry $ mkImportFrom include) $
         progImports $ Prog Nothing [d]
  case res of
    Left err -> liftIO $ print err
    Right (_, imports, src) ->
      case checkProg imports src include prog of
        Left err -> liftIO $ print err
        Right (fm, _, src') -> do
          liftIO $ mapM_ putStrLn $ mapMaybe reportDec $ progDecs $ fileProg fm
          modify $ \s ->
            s { interpDecs = decs ++ [mkOpen prompt]
              , interpNameSource = src'
              , interpImports = imports ++ [(includeToString include, fm)] }

  where curBasis = do
          imports <- gets interpImports
          src <- gets interpNameSource
          return $ Basis { basisImports = imports
                         , basisNameSource = src
                         , basisRoots = basisRoots preludeBasis }

        reportDec (ValDec vb) =
          Just $ "val " <> baseString (valBindName vb) <>
          concatMap ((" "<>) . pretty) (valBindTypeParams vb) <> " : " <>
          pretty (unInfo $ valBindRetType vb)
        reportDec (TypeDec tb) =
          Just $ pretty tb
        reportDec _ = Nothing

onExp :: UncheckedExp -> FutharkiM ()
onExp e = do
  imports <- gets interpImports
  decs <- gets interpDecs
  src <- gets interpNameSource
{'fraction_non_alphanumeric': 0.0958264037380217, 'fraction_numerical': 0.0003167814999604023, 'mean_word_length': 2.336327608982827, 'pattern_counts': {'":': 0, '<': 52, '<?xml version=': 0, '>': 70, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '298164', 'n_tokens_mistral': 3852, 'n_tokens_neox': 3751, 'n_words': 1105}