1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
-- Copyright 2019 Google LLC
--
-- Use of this source code is governed by a BSD-style
-- license that can be found in the LICENSE file or at
-- https://developers.google.com/open-source/licenses/bsd
{-# LANGUAGE DeriveGeneric #-}
import System.Console.Haskeline
import Control.Monad
import Control.Monad.State.Strict
import Options.Applicative
import System.Posix.Terminal (queryTerminal)
import System.Posix.IO (stdOutput)
import System.Exit
import System.Directory
import Syntax
import PPrint
import RenderHtml
import Serialize
import Resources
import TopLevel
import Parser hiding (Parser)
import LiveOutput
data ErrorHandling = HaltOnErr | ContinueOnErr
data DocFmt = ResultOnly | TextDoc | HTMLDoc | JSONDoc
data EvalMode = ReplMode String
| WebMode FilePath
| WatchMode FilePath
| ScriptMode FilePath DocFmt ErrorHandling
data CmdOpts = CmdOpts EvalMode (Maybe FilePath) EvalConfig Backend
runMode :: EvalMode -> (Maybe FilePath) -> EvalConfig -> IO ()
runMode evalMode preludeFile opts = do
key <- case preludeFile of
Nothing -> return "" -- memoizeFileEval already checks compiler version
Just path -> show <$> getModificationTime path
env <- cached "prelude" key $ evalPrelude opts preludeFile
let runEnv m = evalStateT m env
case evalMode of
ReplMode prompt ->
runEnv $ runInputT defaultSettings $ forever (replLoop prompt opts)
ScriptMode fname fmt _ -> do
results <- runEnv $ evalFile opts fname
printLitProg fmt results
-- These are broken if the prelude produces any arrays because the blockId
-- counter restarts at zero. TODO: make prelude an implicit import block
WebMode fname -> runWeb fname opts env
WatchMode fname -> runTerminal fname opts env
evalPrelude :: EvalConfig -> (Maybe FilePath) -> IO TopEnv
evalPrelude opts fname = flip execStateT mempty $ do
source <- case fname of
Nothing -> return $ preludeSource
Just path -> liftIO $ readFile path
result <- evalSource opts source
void $ liftErrIO $ mapM (\(_, Result _ r) -> r) result
liftErrIO :: MonadIO m => Except a -> m a
liftErrIO (Left err) = liftIO $ putStrLn (pprint err) >> exitFailure
liftErrIO (Right x) = return x
replLoop :: String -> EvalConfig -> InputT (StateT TopEnv IO) ()
replLoop prompt opts = do
sourceBlock <- readMultiline prompt parseTopDeclRepl
env <- lift get
result <- lift $ (evalDecl opts) sourceBlock
case result of Result _ (Left _) -> lift $ put env
_ -> return ()
liftIO $ putStrLn $ pprint result
readMultiline :: (MonadException m, MonadIO m) =>
String -> (String -> Maybe a) -> InputT m a
readMultiline prompt parse = loop prompt ""
where
dots = replicate 3 '.' ++ " "
loop prompt' prevRead = do
source <- getInputLine prompt'
case source of
Nothing -> liftIO exitSuccess
Just s -> case parse s' of
Just ans -> return ans
Nothing -> loop dots s'
where s' = prevRead ++ s ++ "\n"
simpleInfo :: Parser a -> ParserInfo a
simpleInfo p = info (p <**> helper) mempty
printLitProg :: DocFmt -> LitProg -> IO ()
printLitProg ResultOnly prog = putStr $ foldMap (nonEmptyNewline . pprint . snd) prog
where
nonEmptyNewline [] = []
nonEmptyNewline l = l ++ ['\n']
printLitProg HTMLDoc prog = putStr $ progHtml prog
printLitProg TextDoc prog = do
isatty <- queryTerminal stdOutput
putStr $ foldMap (uncurry (printLitBlock isatty)) prog
printLitProg JSONDoc prog =
forM_ prog $ \(_, result) -> case toJSONStr result of
"{}" -> return ()
s -> putStrLn s
parseOpts :: ParserInfo CmdOpts
parseOpts = simpleInfo $ CmdOpts <$> parseMode <*> parsePreludeFile <*> parseEvalOpts <*> parseBackend
parseMode :: Parser EvalMode
parseMode = subparser $
(command "repl" $ simpleInfo $
ReplMode <$> (strOption $ long "prompt" <> value ">=> "
<> metavar "STRING" <> help "REPL prompt"))
<> (command "web" $ simpleInfo (WebMode <$> sourceFileInfo ))
<> (command "watch" $ simpleInfo (WatchMode <$> sourceFileInfo ))
<> (command "script" $ simpleInfo (ScriptMode <$> sourceFileInfo
<*> (option
(optionList [ ("literate" , TextDoc)
, ("result-only", ResultOnly)
, ("HTML" , HTMLDoc)
, ("JSON" , JSONDoc)])
(long "outfmt" <> value TextDoc
<> help "Output format (literate(default)|result-only|HTML|JSON"))
<*> flag HaltOnErr ContinueOnErr (
long "allow-errors"
<> help "Evaluate programs containing non-fatal type errors")))
where
sourceFileInfo = argument str (metavar "FILE" <> help "Source program")
optionList :: [(String, a)] -> ReadM a
optionList opts = eitherReader $ \s -> case lookup s opts of
Just x -> Right x
Nothing -> Left $ "Bad option. Expected one of: " ++ show (map fst opts)
parseEvalOpts :: Parser EvalConfig
parseEvalOpts = EvalConfig
<$> (optional $ strOption $ long "logto"
<> metavar "FILE"
<> help "File to log to" <> showDefault)
<*> pure (error "Backend not initialized")
<*> pure (error "Logging not initialized")
parsePreludeFile :: Parser (Maybe FilePath)
parsePreludeFile = optional $ strOption $ long "prelude" <> metavar "FILE" <> help "Prelude file"
parseBackend :: Parser Backend
parseBackend =
(option
(optionList [ ("LLVM", LLVM)
, ("LLVM-CUDA", LLVMCUDA)
, ("LLVM-MC", LLVMMC)
, ("JAX", JAX)
, ("interp", Interp)])
(long "backend" <> value LLVM <> help "Backend (LLVM(default)|LLVM-CUDA|JAX|interp)"))
main :: IO ()
main = do
CmdOpts evalMode preludeFile opts backendName <- execParser parseOpts
engine <- initializeBackend backendName
runMode evalMode preludeFile $ opts { evalEngine = engine }
|
