alms-0.4.12: src/Main.hs
-- | The main driver program, which performs all manner of unpleasant
-- tasks to tie everything together
{-# LANGUAGE CPP #-}
module Main (
main
) where
import Util
import Ppr (Doc, Ppr(..), (<+>), (<>), text, char, hang,
($$), nest, printDoc, hPrintDoc)
import qualified Ppr
import Parser (parseFile, REPLCommand(..), parseCommand)
import Prec (precOp)
import Paths (findAlmsLib, findAlmsLibRel, versionString, shortenPath)
import Printing (addTyNameContext)
import Rename (RenameState, runRenamingM, renameDecls, renameProg,
getRenamingInfo, RenamingInfo(..))
import Statics (tcProg, tcDecls, S, runTC, runTCNew, Module(..),
getExnParam, tyConToDec, getVarInfo, getTypeInfo,
getConInfo)
import Coercion (translate, translateDecls, TEnv, tenv0)
import Value (VExn(..), vppr)
import Dynamics (eval, addDecls, E, NewValues)
import Basis (primBasis, srcBasis)
import BasisUtils (basis2venv, basis2tenv, basis2renv)
import Syntax (Prog, Decl, TyDec, BIdent(..), prog2decls,
Ident, Raw, Renamed)
import Env (empty, (=..=))
import Loc (isBogus, initial, bogus)
import qualified ErrorMessage as EM
import qualified Message.AST as Msg
import Data.Char (isSpace)
import System.Exit (exitFailure)
import System.Environment (getArgs, getProgName, withProgName, withArgs)
import System.IO.Error (ioeGetErrorString, isUserError)
import 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
| Don'tCoerce
| NoBasis
| Verbose
| Quiet
| LoadFile String
| NoLineEdit
deriving Eq
-- | The main procedure
main :: IO ()
main = do
args <- getArgs
processArgs [] args $ \opts mmsrc filename -> do
(primBasis', r0) <- basis2renv primBasis
g0 <- basis2tenv primBasis'
e0 <- basis2venv primBasis'
case mmsrc of
Nothing | Quiet `notElem` opts -> hPutStrLn stderr versionString
_ -> return ()
let st0 = RS r0 g0 tenv0 e0
st1 <- if NoBasis `elem` opts
then return st0
else findAlmsLib srcBasis >>= tryLoadFile st0 srcBasis
st2 <- foldM (\st n -> findAlmsLibRel n "." >>= tryLoadFile st n)
st1 (reverse [ name | LoadFile name <- opts ])
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
loadString :: ReplState -> String -> String -> IO ReplState
loadString st name src = do
case parseFile name src of
Left e -> Exn.throwIO e
Right ast0 -> do
(st1, ast1) <- renaming (st, prog2decls (ast0 :: Prog Raw))
(st2, _, ast2) <- statics False (st1, ast1)
(st3, ast3) <- translation (st2, ast2)
(st4, _) <- dynamics (st3, ast3)
return st4
batch :: String -> IO String -> (Option -> Bool) -> ReplState -> IO ()
batch filename msrc opt st0 = do
src <- msrc
case parseFile filename src of
Left e -> Exn.throwIO e
Right ast -> rename ast where
rename :: Prog Raw -> IO ()
check :: Prog Renamed -> IO ()
coerce :: Prog Renamed -> IO ()
execute :: Prog Renamed -> IO ()
rename ast0 = do
(ast1, _) <- runRenamingM True (initial filename)
(rsRenaming st0) (renameProg ast0)
check ast1
check ast0 = do
((t, ast1), _) <- runTC (rsStatics st0) (tcProg ast0)
when (opt Verbose) $
mumble "TYPE" t
coerce ast1
coerce ast1 =
if opt Don'tCoerce
then execute ast1
else do
let ast2 = translate (rsTranslation st0) ast1
when (opt Verbose) $
mumble "TRANSLATION" ast2
execute ast2
execute ast2 =
unless (opt Don'tExecute) $ do
v <- eval (rsDynamics st0) ast2
when (opt Verbose) $
mumble "RESULT" v
data ReplState = RS {
rsRenaming :: RenameState,
rsStatics :: S,
rsTranslation :: TEnv,
rsDynamics :: E
}
renaming :: (ReplState, [Decl Raw]) -> IO (ReplState, [Decl Renamed])
statics :: Bool -> (ReplState, [Decl Renamed]) ->
IO (ReplState, Module, [Decl Renamed])
translation :: (ReplState, [Decl Renamed]) -> IO (ReplState, [Decl Renamed])
dynamics :: (ReplState, [Decl Renamed]) -> IO (ReplState, NewValues)
renaming (st, ast) = do
(ast', r') <- runRenamingM True (initial "-")
(rsRenaming st) (renameDecls ast)
return (st { rsRenaming = r' }, ast')
statics _ (rs, ast) = do
(ast', new, s') <- runTCNew (rsStatics rs) (tcDecls ast)
return (rs { rsStatics = s' }, new, ast')
translation (rs, ast) = do
let (menv', ast') = translateDecls (rsTranslation rs) ast
return (rs { rsTranslation = menv' }, ast')
dynamics (rs, ast) = do
(e', new) <- addDecls (rsDynamics rs) ast
return (rs { rsDynamics = e' }, new)
carp :: String -> IO ()
carp msg = do
prog <- getProgName
hPutStrLn stderr (prog ++ ": " ++ msg)
handleExns :: IO a -> (ReplState, IO a) -> IO a
handleExns body (st, handler) =
body
`Exn.catches`
[ Exn.Handler $ \e@(VExn { }) -> do
prog <- getProgName
continue $ EM.AlmsException
(EM.OtherError ("Uncaught exception"))
bogus
(Msg.Table [
("in program:", Msg.Exact prog),
("exception:", Msg.Printable (-1) (vppr e))
]),
Exn.Handler continue,
Exn.Handler $ \err ->
continue $ EM.AlmsException EM.DynamicsPhase bogus $
Msg.Flow [Msg.Words (errorString err)],
Exn.Handler $ \(Exn.SomeException err) ->
continue $ EM.AlmsException EM.DynamicsPhase bogus $
Msg.Flow [Msg.Words (show err)] ]
where
continue err = do
hPrintDoc stderr (withRS st (ppr (err :: EM.AlmsException)))
handler
interactive :: (Option -> Bool) -> ReplState -> IO ()
interactive opt rs0 = do
initialize
repl 1 rs0
where
repl row st = do
mres <- reader 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 = let
rename :: (ReplState, [Decl Raw]) -> IO ReplState
check :: (ReplState, [Decl Renamed]) -> IO ReplState
coerce :: Module -> (ReplState, [Decl Renamed]) -> IO ReplState
execute :: Module -> (ReplState, [Decl Renamed]) -> IO ReplState
display :: Module -> NewValues -> ReplState -> IO ReplState
rename (st0, ast0) = do
renaming (st0, ast0) >>= check
check stast0 = do
(st1, newDefs, ast1) <- statics True stast0
coerce newDefs (st1, ast1)
coerce newDefs stast1
= if opt Don'tCoerce
then execute newDefs stast1
else do
stast2 <- translation stast1
when (opt Verbose) $
mumbles "TRANSLATION" (snd stast2)
execute newDefs stast2
execute newDefs stast2
= if opt Don'tExecute
then display newDefs empty (fst stast2)
else do
(st3, newVals) <- dynamics stast2
display newDefs newVals st3
display newDefs newVals st3
= do printResult st3 newDefs newVals
return st3
in rename (st, ast)
getln = if opt NoLineEdit then getline else readline
say = if opt Quiet then const (return ()) else printDoc
get = if opt Quiet then const (getln "") else getln
reader :: Int -> ReplState -> IO (Maybe (Int, [Decl Raw]))
reader row st = loop 1 []
where
fixup = unlines . mapTail (" " ++) . reverse
loop count acc = do
mline <- get (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)
reader (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
DeclsCmd ast -> do
addHistory cmd
return (Just (row + count, ast))
ParseError derr ->
loop (count + 1) ((line, derr) : acc)
printResult :: ReplState -> Module -> NewValues -> IO ()
printResult st md00 values = say (withRS st (loop True md00)) where
loop tl md0 = case md0 of
MdNil -> Ppr.empty
MdApp md1 md2 -> loop tl md1 $$ loop tl md2
MdValue (Var l) t -> pprValue tl l t (values =..= l)
MdValue (Con u) t -> case getExnParam t of
Nothing -> Ppr.empty
Just Nothing -> text "exception"<+>ppr u
Just (Just t') -> text "exception"<+>ppr u<+>text "of"<+>ppr t'
MdTycon _ tc ->
text "type" <+>
Ppr.askTyNames (\tn -> ppr (tyConToDec tn tc :: TyDec Renamed))
MdModule u md1 -> Ppr.enterTyNames u $
text "module" <+> ppr u <+> char ':' <+> text "sig"
$$ nest 2 (loop False md1)
$$ text "end"
MdSig u md1 ->
text "module type" <+> ppr u <+> char '=' <+> text "sig"
$$ nest 2 (loop False md1)
$$ text "end"
pprValue tl x t mv =
addHang '=' (if tl then fmap ppr mv else Nothing) $
addHang ':' (Just (ppr t)) $
(if tl then ppr x else text "val" <+> ppr x)
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 (rsRenaming st) of
[] -> putStrLn $ "Not bound: ‘" ++ show ident ++ "’"
ris -> mapM_ each ris
where
each (SigAt loc x') =
mention "module type" (ppr x') Ppr.empty loc
each (ModuleAt loc x') =
mention "module" (ppr x') Ppr.empty loc
each (VariableAt loc x') =
case getVarInfo x' s of
Nothing -> mention "val" (ppr x') Ppr.empty 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') Ppr.empty loc
Just tc -> mention "type" Ppr.empty (ppr tc) loc
each (DataconAt loc x') =
case getConInfo x' s of
Nothing -> mention "val" (ppr x') Ppr.empty loc
Just (Left mt) ->
mention "type" (text "exn")
(Ppr.sep [ text "= ...",
char '|' <+> ppr x' <+>
case mt of
Nothing -> Ppr.empty
Just t -> text "of" <+> ppr t ])
loc
Just (Right tc) ->
mention "type" Ppr.empty (ppr tc) 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 rs = addTyNameContext (rsRenaming rs) (rsStatics rs)
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)
mumbles :: Ppr a => String -> [a] -> IO ()
mumbles s as = printDoc $ hang (text s <> char ':') 2 (Ppr.vcat (map ppr as))
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 ("-c":r) = loop (Don'tCoerce: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 " -c Don't add contracts"
hPutStrLn stderr " -x Don't execute"
hPutStrLn stderr " -v Verbose (show translation, 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
catch (fmap Just getLine) (\_ -> return Nothing)