alms-0.6.5: src/Main.hs
-- | The main driver program, which performs all manner of unpleasant
-- tasks to tie everything together
module Main (
main,
-- * For interactive exploration from GHCi
makeRS0, check,
) where
import Util
import Util.MonadRef
import Util.UndoIO
import Syntax.ImplicitThreading
import Syntax.Ppr (Doc, Ppr(..), (<+>), (<>), text, char, hang,
printDoc, hPrintDoc)
import qualified Syntax.Ppr as Ppr
import Syntax.Parser (parseFile, REPLCommand(..), parseCommand)
import Syntax.Prec (precOp)
import Paths (findAlmsLib, findAlmsLibRel, versionString, shortenPath)
import Meta.Quasi
import Statics
import Value (VExn(..), vppr)
import Dynamics (eval, addDecls, E, NewValues)
import Basis (primBasis, srcBasis)
import BasisUtils (basis2venv, basis2tenv, basis2renv)
import qualified AST
import AST (Prog, Decl, SigItem, prog2decls,
Ident, Raw, Renamed)
import Env (empty, (=..=))
import Error
import qualified Message.AST as Msg
import Type.Ppr (TyConInfo(..))
import Prelude ()
import Data.Char (isSpace)
import Data.List (nub)
import Data.IORef (IORef)
import System.Exit (exitFailure, exitSuccess, ExitCode)
import System.Environment (getArgs, getProgName, withProgName, withArgs)
import System.IO.Error (ioeGetErrorString, isUserError, catchIOError)
import System.IO (hPutStrLn, hFlush, stdout, stderr)
import qualified Control.Exception as Exn
#ifdef USE_READLINE
import qualified USE_READLINE as RL
#endif
data Option = Don'tExecute
| NoBasis
| Verbose
| Quiet
| LoadFile String
| NoLineEdit
deriving Eq
data ReplState = RS {
rsStatics :: StaticsState IORef,
rsDynamics :: E
}
instance Show ReplState where showsPrec = showsPrec <$.> rsStatics
-- | The main procedure
main :: IO ()
main = do
args <- getArgs
processArgs [] args $ \opts mmsrc filename -> do
st0 <- makeRS0
case mmsrc of
Nothing | Quiet `notElem` opts -> hPutStrLn stderr versionString
_ -> return ()
st1 <- (if NoBasis `elem` opts
then return st0
else findAlmsLib srcBasis >>= tryLoadFile st0 srcBasis)
`handleExns` (st0, exitFailure)
st2 <- foldM (\st n -> findAlmsLibRel n "." >>= tryLoadFile st n)
st1 (reverse [ name | LoadFile name <- opts ])
`handleExns` (st1, exitFailure)
maybe interactive (batch filename) mmsrc (`elem` opts) st2
`handleExns` (st2, exitFailure)
tryLoadFile :: ReplState -> String -> Maybe String -> IO ReplState
tryLoadFile st name mfile = case mfile of
Nothing -> do
carp $ name ++ ": could not load"
return st
Just file -> loadFile st file
loadFile :: ReplState -> String -> IO ReplState
loadFile st name = do
src <- readFile name
name' <- shortenPath name
loadString st name' src
makeRS0 :: IO ReplState
makeRS0 = do
(primBasis', r0) <- basis2renv primBasis
g0 <- basis2tenv (staticsState0 r0) primBasis'
e0 <- basis2venv primBasis'
return (RS g0 e0)
-- For trying things from GHCi
check :: ReplState -> String -> IO ReplState
check rs = loadString rs "<check>"
loadString :: ReplState -> String -> String -> IO ReplState
loadString st name src = do
case parseFile name src of
Left e -> Exn.throwIO e
Right ast -> do
ast1 <- runAlmsErrorIO (mapM threadDecl (prog2decls ast))
(st2, _, ast2) <- runAlmsErrorIO (statics (st, ast1))
(st3, _) <- dynamics (st2, ast2)
return st3
batch :: String -> IO String -> (Option -> Bool) -> ReplState -> IO ()
batch filename msrc opt st = do
src <- msrc
case parseFile filename src of
Left e -> Exn.throwIO e
Right ast -> thread ast where
thread :: Prog Raw -> IO ()
typecheck :: Prog Raw -> IO ()
execute :: Prog Renamed -> IO ()
thread ast0 = do
ast1 <- runAlmsErrorIO (threadProg ast0)
when (opt Verbose) $
mumble "THREADING" ast1
typecheck ast1
typecheck ast1 = do
(ast2, mt) <- runAlmsErrorIO (typeCheckProg (rsStatics st) ast1)
when (opt Verbose) $
mumble "TYPE" mt
execute ast2
execute ast2 =
unless (opt Don'tExecute) $ do
v <- eval (rsDynamics st) ast2
when (opt Verbose) $
mumble "RESULT" v
statics :: (MonadRef IORef m, MonadAlmsError m) ⇒
(ReplState, [Decl Raw]) ->
m (ReplState, [SigItem Renamed], [Decl Renamed])
dynamics :: (ReplState, [Decl Renamed]) -> IO (ReplState, NewValues)
statics (rs, ast) = do
(ast', sig, s') <- typeCheckDecls (rsStatics rs) ast
return (rs { rsStatics = s' }, sig, ast')
dynamics (rs, ast) = do
(e', new) <- addDecls (rsDynamics rs) ast
return (rs { rsDynamics = e' }, new)
carp :: String -> IO ()
carp message = do
prog <- getProgName
hPutStrLn stderr (prog ++ ": " ++ message)
handleExns :: IO a -> (ReplState, IO a) -> IO a
handleExns body (st, handler) =
body
`Exn.catches`
[ Exn.Handler $ \(e ∷ ExitCode) -> Exn.throwIO e,
Exn.Handler $ \e@(VExn { }) -> do
prog <- getProgName
continue1 $
AlmsError
(OtherError ("Uncaught exception"))
bogus
(Msg.Table [
("in program:", Msg.Exact prog),
("exception:", Msg.Printable (-1) (vppr e))
]),
Exn.Handler continue1,
Exn.Handler continue,
Exn.Handler $ \err ->
continue1 $ AlmsError DynamicsPhase bogus $
Msg.Flow [Msg.Words (errorString err)],
Exn.Handler $ \(Exn.SomeException err) ->
continue1 $ AlmsError DynamicsPhase bogus $
Msg.Flow [Msg.Words (show err)] ]
where
continue1 err = continue (AlmsErrorIO [err])
continue errs = do
for (nub (unAlmsErrorIO errs)) $ \err -> do
hPrintDoc stderr (withRS st (ppr err))
hPutStrLn stderr ""
handler
interactive :: (Option -> Bool) -> ReplState -> IO ()
interactive opt rs0 = do
initialize
repl 1 rs0
where
repl row st = do
mres <- readr row st
case mres of
Nothing -> return ()
Just (row', ast) -> do
st' <- doLine st ast `handleExns` (st, return st)
repl row' st'
doLine st ast = do
ast1 <- runAlmsErrorIO (threadDecls ast)
when (opt Verbose) (mumble "THREADING" ast1)
(st2, newDefs, ast2) <- runUndoIO (runAlmsErrorIO (statics (st, ast1)))
(st3, newVals) <- if opt Don'tExecute
then return (st2, empty)
else dynamics (st2, ast2)
printResult newDefs newVals
return st3
say = if opt Quiet then const (return ()) else printDoc
getln' = if opt NoLineEdit then getline else readline
getln = if opt Quiet then const (getln' "") else getln'
readr :: Int -> ReplState -> IO (Maybe (Int, [Decl Raw]))
readr row st = loop 1 []
where
fixup = unlines . mapTail (" " ++) . reverse
loop count acc = do
mline <- getln (if null acc then "#- " else "#= ")
case (mline, acc) of
(Nothing, []) -> return Nothing
(Nothing, (_,err):_) -> do
addHistory (fixup (map fst acc))
hPutStrLn stderr ""
hPutStrLn stderr (show err)
readr (row + count) st
(Just line, _)
| all isSpace line -> loop count acc
| otherwise ->
let cmd = fixup (line : map fst acc) in
case parseCommand row line cmd of
GetInfoCmd ids -> do
mapM_ (printInfo st) ids
addHistory line
loop (count + 1) acc
GetPrecCmd lids -> do
mapM_ printPrec lids
addHistory line
loop (count + 1) acc
GetConstraintCmd -> do
say (getConstraint (rsStatics st))
addHistory line
loop (count + 1) acc
QuitCmd -> exitSuccess
DeclsCmd ast -> do
addHistory cmd
return (Just (row + count, ast))
ParseError derr ->
loop (count + 1) ((line, derr) : acc)
printResult :: [SigItem Renamed] -> NewValues -> IO ()
printResult types values = mapM_ (say . eachItem) types
where
eachItem sigitem = case sigitem of
[sgQ| val $vid:n : $t |]
→ addHang '=' (ppr <$> values =..= n) $
addHang ':' (Just (ppr t)) $
ppr n
_ → ppr sigitem
addHang c m d = case m of
Nothing -> d
Just t -> hang (d <+> char c) 2 t
printInfo :: ReplState -> Ident Raw -> IO ()
printInfo st ident = case getRenamingInfo ident s of
[] -> putStrLn $ "Not bound: ‘" ++ show ident ++ "’"
ris -> mapM_ each ris
where
each (SigAt loc x') =
mention "module type" (ppr x') mempty loc
each (ModuleAt loc x') =
mention "module" (ppr x') mempty loc
each (VariableAt loc x') =
case getVarInfo x' s of
Nothing -> mention "val" (ppr x') mempty loc
Just t -> mention "val" (ppr x') (char ':' <+> ppr t) loc
each (TyconAt loc x') =
case getTypeInfo x' s of
Nothing -> mention "type" (ppr x') mempty loc
Just tc -> mention "type" mempty (ppr (TyConInfo tc)) loc
each (DataconAt loc x') =
case getConInfo x' s of
Nothing -> mention "val" (ppr x') mempty loc
Just (Left tc) ->
mention "type" mempty (ppr (TyConInfo tc)) loc
Just (Right mt) ->
mention "type" (text "exn")
(Ppr.sep [ text "= ...",
char '|' <+> ppr x' <+>
case mt of
Nothing -> mempty
Just t -> text "of" <+> ppr t ])
loc
--
s = rsStatics st
--
mention what who rhs loc = do
printDoc $
withRS st $
text what <+> ppr who
>?> rhs Ppr.>?>
if isBogus loc
then text " -- built-in"
else text " -- defined at" <+> text (show loc)
where a >?> b = Ppr.ifEmpty who (a <+> b) (a Ppr.>?> b)
-- Add the ReplState to the pretty-printing context.
withRS :: ReplState -> Doc -> Doc
withRS = addTyNameContext . rsStatics
printPrec :: String -> IO ()
printPrec oper = printDoc $
hang (text oper)
2
(text ":" <+> text (show (precOp oper)))
mumble :: Ppr a => String -> a -> IO ()
mumble s a = printDoc $ hang (text s <> char ':') 2 (ppr a)
errorString :: IOError -> String
errorString e | isUserError e = ioeGetErrorString e
| otherwise = show e
processArgs :: [Option] -> [String] ->
([Option] -> Maybe (IO String) -> String -> IO a) ->
IO a
processArgs opts0 args0 k = loop opts0 args0 where
loop opts [] = go "-" [] opts Nothing
loop opts ("-":args)
= go "-" args opts (Just getContents)
loop opts ("--":name:args)
= go name args opts (Just (readFile name))
loop opts ("-l":name:r)
= loop (LoadFile name:opts) r
loop opts (('-':'l':name):r)
= loop (LoadFile name:opts) r
loop opts ("-b":r) = loop (NoBasis:opts) r
loop opts ("-x":r) = loop (Don'tExecute:opts) r
loop opts ("-v":r) = loop (Verbose:opts) r
loop opts ("-q":r) = loop (Quiet:opts) r
loop opts ("-e":r) = loop (NoLineEdit:opts) r
loop opts (('-':c:d:e):r)
= loop opts (['-',c]:('-':d:e):r)
loop _ (('-':_):_) = usage
loop opts (name:args) = go name args opts (Just (readFile name))
go name args opts mmsrc =
withProgName name $
withArgs args $
k opts mmsrc name
usage :: IO a
usage = do
hPutStrLn stderr "Usage: alms [OPTIONS...] [--] [FILENAME] [ARGS...]"
hPutStrLn stderr ""
hPutStrLn stderr "Options:"
hPutStrLn stderr " -l FILE Load file"
hPutStrLn stderr " -q Don't print prompt, greeting, responses"
hPutStrLn stderr " -e Don't use line editing"
hPutStrLn stderr ""
hPutStrLn stderr "Debugging options:"
hPutStrLn stderr " -b Don't load libbasis.alms"
hPutStrLn stderr " -x Don't execute"
hPutStrLn stderr " -v Verbose (show results, types)"
exitFailure
initialize :: IO ()
addHistory :: String -> IO ()
readline :: String -> IO (Maybe String)
#ifdef USE_READLINE
initialize = RL.initialize
addHistory = RL.addHistory
readline = RL.readline
#else
initialize = return ()
addHistory _ = return ()
readline = getline
#endif
getline :: String -> IO (Maybe String)
getline s = do
putStr s
hFlush stdout
catchIOError (fmap Just getLine) (\_ -> return Nothing)