forked from GitHub/gf-core
gf -cshell: preliminary support for the C run-time system in the GF shell
Some C run-time functionality is now available in the GF shell, by starting GF with 'gf -cshell' or 'gf -crun'. Only limited functionality is available when running the shell in these modes: - You can only import .pgf files, not source files. - The -retain flag can not be used and the commands that require it to work are not available. - Only 18 of the 40 commands available in the usual shell have been implemented. The 'linearize' and 'parse' commands are the only ones that call the C run-time system, and they support only a limited set of options and flags. Use the 'help' commmands for details. - A new command 'generate_all', that calls PGF2.generateAll, has been added. Unfortuntaly, using it causes 'segmentation fault'. This is implemented by adding two new modules: GF.Command.Commands2 and GF.Interactive2. They are copied and modified versions of GF.Command.Commands and GF.Interactive, respectively. Code for unimplemented commands and other code that has not been adapted to the C run-time system has been left in place, but commented out, pending further work.
This commit is contained in:
hallgren
15
gf.cabal
15
gf.cabal
@@ -132,13 +132,14 @@ Library
|
||||
PGF.OldBinary
|
||||
|
||||
if flag(c-runtime)
|
||||
exposed-modules: PGF2
|
||||
other-modules: PGF2.FFI
|
||||
hs-source-dirs: src/runtime/haskell-bind
|
||||
build-tools: hsc2hs
|
||||
extra-libraries: gu pgf
|
||||
c-sources: src/runtime/haskell-bind/utils.c
|
||||
cc-options: -std=c99
|
||||
exposed-modules: PGF2
|
||||
other-modules: PGF2.FFI
|
||||
GF.Interactive2 GF.Command.Commands2
|
||||
hs-source-dirs: src/runtime/haskell-bind
|
||||
build-tools: hsc2hs
|
||||
extra-libraries: gu pgf
|
||||
c-sources: src/runtime/haskell-bind/utils.c
|
||||
cc-options: -std=c99
|
||||
|
||||
---- GF compiler as a library:
|
||||
|
||||
|
||||
1425
src/compiler/GF/Command/Commands2.hs
Normal file
1425
src/compiler/GF/Command/Commands2.hs
Normal file
File diff suppressed because it is too large
Load Diff
@@ -73,7 +73,10 @@ errors = raise . unlines
|
||||
|
||||
-- Types
|
||||
|
||||
data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeRun | ModeCompiler
|
||||
data Mode = ModeVersion | ModeHelp
|
||||
| ModeInteractive | ModeRun
|
||||
| ModeInteractive2 | ModeRun2
|
||||
| ModeCompiler
|
||||
| ModeServer {-port::-}Int
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
@@ -302,6 +305,8 @@ optDescr =
|
||||
Option ['j'] ["jobs"] (OptArg jobs "N") "Compile N modules in parallel with -batch (default 1).",
|
||||
Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
|
||||
Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).",
|
||||
Option [] ["cshell"] (NoArg (mode ModeInteractive2)) "Start the C run-time shell.",
|
||||
Option [] ["crun"] (NoArg (mode ModeRun2)) "Start the C run-time shell, showing output only (no other messages).",
|
||||
Option [] ["server"] (OptArg modeServer "port") $
|
||||
"Run in HTTP server mode on given port (default "++show defaultPort++").",
|
||||
Option [] ["document-root"] (ReqArg gfDocuRoot "DIR")
|
||||
|
||||
@@ -1,5 +1,6 @@
|
||||
-- | Shell IO: a monad that can restrict acesss to arbitrary IO and has the
|
||||
-- ability to capture output that normally would be sent to stdout.
|
||||
{-# LANGUAGE CPP #-}
|
||||
module GF.Infra.SIO(
|
||||
-- * The SIO monad
|
||||
SIO,
|
||||
@@ -11,6 +12,9 @@ module GF.Infra.SIO(
|
||||
newStdGen,print,putStrLn,
|
||||
-- ** Specific to GF
|
||||
importGrammar,importSource,
|
||||
#ifdef C_RUNTIME
|
||||
readPGF2,
|
||||
#endif
|
||||
putStrLnFlush,runInterruptibly,lazySIO,
|
||||
-- * Restricted accesss to arbitrary (potentially unsafe) IO operations
|
||||
-- | If the environment variable GF_RESTRICTED is defined, these
|
||||
@@ -33,6 +37,9 @@ import qualified System.Random as IO(newStdGen)
|
||||
import qualified GF.Infra.UseIO as IO(getLibraryDirectory)
|
||||
import qualified GF.System.Signal as IO(runInterruptibly)
|
||||
import qualified GF.Command.Importing as GF(importGrammar, importSource)
|
||||
#ifdef C_RUNTIME
|
||||
import qualified PGF2
|
||||
#endif
|
||||
|
||||
-- * The SIO monad
|
||||
|
||||
@@ -96,3 +103,7 @@ lazySIO = lift1 lazyIO
|
||||
|
||||
importGrammar pgf opts files = lift0 $ GF.importGrammar pgf opts files
|
||||
importSource opts files = lift0 $ GF.importSource opts files
|
||||
|
||||
#ifdef C_RUNTIME
|
||||
readPGF2 = lift0 . PGF2.readPGF
|
||||
#endif
|
||||
|
||||
538
src/compiler/GF/Interactive2.hs
Normal file
538
src/compiler/GF/Interactive2.hs
Normal file
@@ -0,0 +1,538 @@
|
||||
{-# LANGUAGE ScopedTypeVariables, CPP #-}
|
||||
-- | GF interactive mode (with the C run-time system)
|
||||
module GF.Interactive2 (mainGFI,mainRunGFI{-,mainServerGFI-}) where
|
||||
import Prelude hiding (putStrLn,print)
|
||||
import qualified Prelude as P(putStrLn)
|
||||
import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,interpretCommandLine)
|
||||
--import GF.Command.Importing(importSource,importGrammar)
|
||||
import GF.Command.Commands2(flags,options,PGFEnv,pgfEnv,emptyPGFEnv,allCommands)
|
||||
import GF.Command.Abstract
|
||||
import GF.Command.Parse(readCommandLine,pCommand)
|
||||
import GF.Data.Operations (Err(..),chunks,err,raise,done)
|
||||
import GF.Grammar hiding (Ident,isPrefixOf)
|
||||
import GF.Grammar.Analyse
|
||||
import GF.Grammar.Parser (runP, pExp)
|
||||
import GF.Grammar.ShowTerm
|
||||
import GF.Grammar.Lookup (allOpers,allOpersTo)
|
||||
import GF.Compile.Rename(renameSourceTerm)
|
||||
--import GF.Compile.Compute.Concrete (computeConcrete,checkPredefError)
|
||||
import qualified GF.Compile.Compute.ConcreteNew as CN(normalForm,resourceValues)
|
||||
import GF.Compile.TypeCheck.RConcrete as TC(inferLType,ppType)
|
||||
import GF.Infra.Dependencies(depGraph)
|
||||
import GF.Infra.CheckM
|
||||
import GF.Infra.UseIO(ioErrorText)
|
||||
import GF.Infra.SIO
|
||||
import GF.Infra.Option
|
||||
import qualified System.Console.Haskeline as Haskeline
|
||||
--import GF.Text.Coding(decodeUnicode,encodeUnicode)
|
||||
|
||||
--import GF.Compile.Coding(codeTerm)
|
||||
|
||||
import qualified PGF2 as C
|
||||
import qualified PGF as H
|
||||
import qualified PGF.Internal as H(emptyPGF,abstract,funs,lookStartCat)
|
||||
|
||||
import Data.Char
|
||||
import Data.List(nub,isPrefixOf,isInfixOf,partition)
|
||||
import qualified Data.Map as Map
|
||||
--import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.UTF8 as UTF8(fromString)
|
||||
import qualified Text.ParserCombinators.ReadP as RP
|
||||
--import System.IO(utf8)
|
||||
--import System.CPUTime(getCPUTime)
|
||||
import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory)
|
||||
import System.FilePath(takeExtensions)
|
||||
import Control.Exception(SomeException,fromException,evaluate,try)
|
||||
import Control.Monad
|
||||
import GF.Text.Pretty (render)
|
||||
import qualified GF.System.Signal as IO(runInterruptibly)
|
||||
{-
|
||||
#ifdef SERVER_MODE
|
||||
import GF.Server(server)
|
||||
#endif
|
||||
-}
|
||||
import GF.System.Console(changeConsoleEncoding)
|
||||
|
||||
import GF.Infra.BuildInfo(buildInfo)
|
||||
import Data.Version(showVersion)
|
||||
import Paths_gf(version)
|
||||
|
||||
-- | Run the GF Shell in quiet mode (@gf -run@).
|
||||
mainRunGFI :: Options -> [FilePath] -> IO ()
|
||||
mainRunGFI opts files = shell (beQuiet opts) files
|
||||
|
||||
beQuiet = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet}))
|
||||
|
||||
-- | Run the interactive GF Shell
|
||||
mainGFI :: Options -> [FilePath] -> IO ()
|
||||
mainGFI opts files = do
|
||||
P.putStrLn welcome
|
||||
shell opts files
|
||||
|
||||
shell opts files = loop opts =<< runSIO (importInEnv emptyGFEnv opts files)
|
||||
{-
|
||||
#ifdef SERVER_MODE
|
||||
-- | Run the GF Server (@gf -server@).
|
||||
-- The 'Int' argument is the port number for the HTTP service.
|
||||
mainServerGFI opts0 port files =
|
||||
server jobs port root (execute1 opts)
|
||||
=<< runSIO (importInEnv emptyGFEnv opts files)
|
||||
where
|
||||
root = flag optDocumentRoot opts
|
||||
opts = beQuiet opts0
|
||||
jobs = join (flag optJobs opts)
|
||||
#else
|
||||
mainServerGFI opts files =
|
||||
error "GF has not been compiled with server mode support"
|
||||
#endif
|
||||
-}
|
||||
-- | Read end execute commands until it is time to quit
|
||||
loop :: Options -> GFEnv -> IO ()
|
||||
loop opts gfenv = maybe done (loop opts) =<< readAndExecute1 opts gfenv
|
||||
|
||||
-- | Read and execute one command, returning Just an updated environment for
|
||||
-- | the next command, or Nothing when it is time to quit
|
||||
readAndExecute1 :: Options -> GFEnv -> IO (Maybe GFEnv)
|
||||
readAndExecute1 opts gfenv =
|
||||
runSIO . execute1 opts gfenv =<< readCommand opts gfenv
|
||||
|
||||
-- | Read a command
|
||||
readCommand :: Options -> GFEnv -> IO String
|
||||
readCommand opts gfenv0 =
|
||||
case flag optMode opts of
|
||||
ModeRun -> tryGetLine
|
||||
_ -> fetchCommand gfenv0
|
||||
|
||||
-- | Optionally show how much CPU time was used to run an IO action
|
||||
optionallyShowCPUTime :: Options -> SIO a -> SIO a
|
||||
optionallyShowCPUTime opts act
|
||||
| not (verbAtLeast opts Normal) = act
|
||||
| otherwise = do t0 <- getCPUTime
|
||||
r <- act
|
||||
t1 <- getCPUTime
|
||||
let dt = t1-t0
|
||||
putStrLnFlush $ show (dt `div` 1000000000) ++ " msec"
|
||||
return r
|
||||
|
||||
{-
|
||||
loopOptNewCPU opts gfenv'
|
||||
| not (verbAtLeast opts Normal) = return gfenv'
|
||||
| otherwise = do
|
||||
cpu' <- getCPUTime
|
||||
putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec")
|
||||
return $ gfenv' {cputime = cpu'}
|
||||
-}
|
||||
|
||||
-- | Execute a given command, returning Just an updated environment for
|
||||
-- | the next command, or Nothing when it is time to quit
|
||||
execute1 :: Options -> GFEnv -> String -> SIO (Maybe GFEnv)
|
||||
execute1 opts gfenv0 s0 =
|
||||
interruptible $ optionallyShowCPUTime opts $
|
||||
case pwords s0 of
|
||||
-- special commands, requiring source grammar in env
|
||||
{-"eh":w:_ -> do
|
||||
cs <- readFile w >>= return . map words . lines
|
||||
gfenv' <- foldM (flip (process False benv)) gfenv cs
|
||||
loopNewCPU gfenv' -}
|
||||
"q" :_ -> quit
|
||||
"!" :ws -> system_command ws
|
||||
-- "cc":ws -> compute_concrete ws
|
||||
-- "sd":ws -> show_deps ws
|
||||
-- "so":ws -> show_operations ws
|
||||
-- "ss":ws -> show_source ws
|
||||
-- "dg":ws -> dependency_graph ws
|
||||
"eh":ws -> eh ws
|
||||
"i" :ws -> import_ ws
|
||||
-- other special commands, working on GFEnv
|
||||
"e" :_ -> empty
|
||||
"dc":ws -> define_command ws
|
||||
"dt":ws -> define_tree ws
|
||||
"ph":_ -> print_history
|
||||
"r" :_ -> reload_last
|
||||
"se":ws -> set_encoding ws
|
||||
-- ordinary commands, working on CommandEnv
|
||||
_ -> do interpretCommandLine env s0
|
||||
continue gfenv
|
||||
where
|
||||
-- loopNewCPU = fmap Just . loopOptNewCPU opts
|
||||
continue = return . Just
|
||||
stop = return Nothing
|
||||
env = commandenv gfenv0
|
||||
-- sgr = grammar gfenv0
|
||||
gfenv = gfenv0 {history = s0 : history gfenv0}
|
||||
pwords s = case words s of
|
||||
w:ws -> getCommandOp w :ws
|
||||
ws -> ws
|
||||
|
||||
interruptible act =
|
||||
either (\e -> printException e >> return (Just gfenv)) return
|
||||
=<< runInterruptibly act
|
||||
|
||||
-- Special commands:
|
||||
|
||||
quit = do when (verbAtLeast opts Normal) $ putStrLn "See you."
|
||||
stop
|
||||
|
||||
system_command ws = do restrictedSystem $ unwords ws ; continue gfenv
|
||||
{-
|
||||
compute_concrete ws = do
|
||||
let
|
||||
pOpts style q ("-table" :ws) = pOpts TermPrintTable q ws
|
||||
pOpts style q ("-all" :ws) = pOpts TermPrintAll q ws
|
||||
pOpts style q ("-list" :ws) = pOpts TermPrintList q ws
|
||||
pOpts style q ("-one" :ws) = pOpts TermPrintOne q ws
|
||||
pOpts style q ("-default":ws) = pOpts TermPrintDefault q ws
|
||||
pOpts style q ("-unqual" :ws) = pOpts style Unqualified ws
|
||||
pOpts style q ("-qual" :ws) = pOpts style Qualified ws
|
||||
pOpts style q ws = (style,q,unwords ws)
|
||||
|
||||
(style,q,s) = pOpts TermPrintDefault Qualified ws
|
||||
{-
|
||||
(new,ws') = case ws of
|
||||
"-new":ws' -> (True,ws')
|
||||
"-old":ws' -> (False,ws')
|
||||
_ -> (flag optNewComp opts,ws)
|
||||
-}
|
||||
case runP pExp (UTF8.fromString s) of
|
||||
Left (_,msg) -> putStrLn msg
|
||||
Right t -> putStrLn . err id (showTerm sgr style q)
|
||||
. checkComputeTerm sgr
|
||||
$ {-codeTerm (decodeUnicode utf8 . BS.pack)-} t
|
||||
continue gfenv
|
||||
|
||||
show_deps ws = do
|
||||
let (os,xs) = partition (isPrefixOf "-") ws
|
||||
ops <- case xs of
|
||||
_:_ -> do
|
||||
let ts = [t | Right t <- map (runP pExp . UTF8.fromString) xs]
|
||||
err error (return . nub . concat) $ mapM (constantDepsTerm sgr) ts
|
||||
_ -> error "expected one or more qualified constants as argument"
|
||||
let prTerm = showTerm sgr TermPrintDefault Qualified
|
||||
let size = sizeConstant sgr
|
||||
let printed
|
||||
| elem "-size" os =
|
||||
let sz = map size ops in
|
||||
unlines $ ("total: " ++ show (sum sz)) :
|
||||
[prTerm f ++ "\t" ++ show s | (f,s) <- zip ops sz]
|
||||
| otherwise = unwords $ map prTerm ops
|
||||
putStrLn $ printed
|
||||
continue gfenv
|
||||
|
||||
show_operations ws =
|
||||
case greatestResource sgr of
|
||||
Nothing -> putStrLn "no source grammar in scope; did you import with -retain?" >> continue gfenv
|
||||
Just mo -> do
|
||||
let (os,ts) = partition (isPrefixOf "-") ws
|
||||
let greps = [drop 6 o | o <- os, take 6 o == "-grep="]
|
||||
let isRaw = elem "-raw" os
|
||||
ops <- case ts of
|
||||
_:_ -> do
|
||||
let Right t = runP pExp (UTF8.fromString (unwords ts))
|
||||
ty <- err error return $ checkComputeTerm sgr t
|
||||
return $ allOpersTo sgr ty
|
||||
_ -> return $ allOpers sgr
|
||||
let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
|
||||
let printer = if isRaw
|
||||
then showTerm sgr TermPrintDefault Qualified
|
||||
else (render . TC.ppType)
|
||||
let printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
|
||||
mapM_ putStrLn [l | l <- printed, all (flip isInfixOf l) greps]
|
||||
continue gfenv
|
||||
|
||||
show_source ws = do
|
||||
let (os,ts) = partition (isPrefixOf "-") ws
|
||||
let strip = if elem "-strip" os then stripSourceGrammar else id
|
||||
let mygr = strip $ case ts of
|
||||
_:_ -> mGrammar [(i,m) | (i,m) <- modules sgr, elem (render i) ts]
|
||||
[] -> sgr
|
||||
case 0 of
|
||||
_ | elem "-detailedsize" os -> putStrLn (printSizesGrammar mygr)
|
||||
_ | elem "-size" os -> do
|
||||
let sz = sizesGrammar mygr
|
||||
putStrLn $ unlines $
|
||||
("total\t" ++ show (fst sz)):
|
||||
[render j ++ "\t" ++ show (fst k) | (j,k) <- snd sz]
|
||||
_ | elem "-save" os -> mapM_
|
||||
(\ m@(i,_) -> let file = (render i ++ ".gfh") in
|
||||
restricted $ writeFile file (render (ppModule Qualified m)) >> P.putStrLn ("wrote " ++ file))
|
||||
(modules mygr)
|
||||
_ -> putStrLn $ render mygr
|
||||
continue gfenv
|
||||
|
||||
dependency_graph ws =
|
||||
do let stop = case ws of
|
||||
('-':'o':'n':'l':'y':'=':fs):_ -> Just $ chunks ',' fs
|
||||
_ -> Nothing
|
||||
restricted $ writeFile "_gfdepgraph.dot" (depGraph stop sgr)
|
||||
putStrLn "wrote graph in file _gfdepgraph.dot"
|
||||
continue gfenv
|
||||
-}
|
||||
eh [w] = -- Ehhh? Reads commands from a file, but does not execute them
|
||||
do cs <- restricted (readFile w) >>= return . map (interpretCommandLine env) . lines
|
||||
continue gfenv
|
||||
eh _ = do putStrLn "eh command not parsed"
|
||||
continue gfenv
|
||||
|
||||
import_ args =
|
||||
do gfenv' <- case parseOptions args of
|
||||
Ok (opts',files) -> do
|
||||
curr_dir <- getCurrentDirectory
|
||||
lib_dir <- getLibraryDirectory (addOptions opts opts')
|
||||
importInEnv gfenv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
|
||||
Bad err -> do
|
||||
putStrLn $ "Command parse error: " ++ err
|
||||
return gfenv
|
||||
continue gfenv'
|
||||
|
||||
empty = continue $ gfenv {
|
||||
commandenv=emptyCommandEnv --, grammar = ()
|
||||
}
|
||||
|
||||
define_command (f:ws) =
|
||||
case readCommandLine (unwords ws) of
|
||||
Just comm -> continue $ gfenv {
|
||||
commandenv = env {
|
||||
commandmacros = Map.insert f comm (commandmacros env)
|
||||
}
|
||||
}
|
||||
_ -> dc_not_parsed
|
||||
define_command _ = dc_not_parsed
|
||||
|
||||
dc_not_parsed = putStrLn "command definition not parsed" >> continue gfenv
|
||||
|
||||
define_tree (f:ws) =
|
||||
case H.readExpr (unwords ws) of
|
||||
Just exp -> continue $ gfenv {
|
||||
commandenv = env {
|
||||
expmacros = Map.insert f exp (expmacros env)
|
||||
}
|
||||
}
|
||||
_ -> dt_not_parsed
|
||||
define_tree _ = dt_not_parsed
|
||||
|
||||
dt_not_parsed = putStrLn "value definition not parsed" >> continue gfenv
|
||||
|
||||
print_history = mapM_ putStrLn (reverse (history gfenv0))>> continue gfenv
|
||||
|
||||
reload_last = do
|
||||
let imports = [(s,ws) | s <- history gfenv0, ("i":ws) <- [pwords s]]
|
||||
case imports of
|
||||
(s,ws):_ -> do
|
||||
putStrLn $ "repeating latest import: " ++ s
|
||||
import_ ws
|
||||
_ -> do
|
||||
putStrLn $ "no import in history"
|
||||
continue gfenv
|
||||
|
||||
set_encoding [c] =
|
||||
do let cod = renameEncoding c
|
||||
restricted $ changeConsoleEncoding cod
|
||||
continue gfenv
|
||||
set_encoding _ = putStrLn "se command not parsed" >> continue gfenv
|
||||
|
||||
|
||||
printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e)
|
||||
|
||||
checkComputeTerm sgr t = do
|
||||
mo <- maybe (raise "no source grammar in scope") return $ greatestResource sgr
|
||||
((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
|
||||
inferLType sgr [] t
|
||||
t1 <- return (CN.normalForm (CN.resourceValues noOptions sgr) (L NoLoc identW) t)
|
||||
checkPredefError t1
|
||||
|
||||
fetchCommand :: GFEnv -> IO String
|
||||
fetchCommand gfenv = do
|
||||
path <- getAppUserDataDirectory "gf_history"
|
||||
let settings =
|
||||
Haskeline.Settings {
|
||||
Haskeline.complete = wordCompletion gfenv,
|
||||
Haskeline.historyFile = Just path,
|
||||
Haskeline.autoAddHistory = True
|
||||
}
|
||||
res <- IO.runInterruptibly $ Haskeline.runInputT settings (Haskeline.getInputLine (prompt gfenv))
|
||||
case res of
|
||||
Left _ -> return ""
|
||||
Right Nothing -> return "q"
|
||||
Right (Just s) -> return s
|
||||
|
||||
importInEnv :: GFEnv -> Options -> [FilePath] -> SIO GFEnv
|
||||
importInEnv gfenv opts files =
|
||||
case files of
|
||||
_ | flag optRetainResource opts ->
|
||||
do putStrLn "Flag -retain is not supported in this shell"
|
||||
return gfenv
|
||||
[file] | takeExtensions file == ".pgf" -> importPGF file
|
||||
[] -> return gfenv
|
||||
_ -> do putStrLn "Can only import one .pgf file"
|
||||
return gfenv
|
||||
where
|
||||
importPGF file =
|
||||
do case multigrammar (commandenv gfenv) of
|
||||
Just _ -> putStrLnFlush "Discarding previous grammar"
|
||||
_ -> done
|
||||
pgf1 <- readPGF2 file
|
||||
let gfenv' = gfenv { commandenv = commandEnv pgf1 }
|
||||
when (verbAtLeast opts Normal) $
|
||||
let langs = Map.keys . concretes $ commandenv gfenv'
|
||||
in putStrLnFlush . unwords $ "\nLanguages:":langs
|
||||
return gfenv'
|
||||
|
||||
tryGetLine = do
|
||||
res <- try getLine
|
||||
case res of
|
||||
Left (e :: SomeException) -> return "q"
|
||||
Right l -> return l
|
||||
|
||||
welcome = unlines [
|
||||
" ",
|
||||
" * * * ",
|
||||
" * * ",
|
||||
" * * ",
|
||||
" * ",
|
||||
" * ",
|
||||
" * * * * * * * ",
|
||||
" * * * ",
|
||||
" * * * * * * ",
|
||||
" * * * ",
|
||||
" * * * ",
|
||||
" ",
|
||||
"This is GF version "++showVersion version++". ",
|
||||
buildInfo,
|
||||
"License: see help -license. ",
|
||||
--"Bug reports: http://code.google.com/p/grammatical-framework/issues/list",
|
||||
"",
|
||||
"This shell uses the C run-time system. See help for available commands."
|
||||
]
|
||||
|
||||
prompt env = abs ++ "> "
|
||||
where
|
||||
abs = maybe "" C.abstractName (multigrammar (commandenv env))
|
||||
|
||||
data GFEnv = GFEnv {
|
||||
--grammar :: (), -- gfo grammar -retain
|
||||
--retain :: (), -- grammar was imported with -retain flag
|
||||
commandenv :: CommandEnv PGFEnv,
|
||||
history :: [String]
|
||||
}
|
||||
|
||||
emptyGFEnv :: GFEnv
|
||||
emptyGFEnv = GFEnv {-() ()-} emptyCommandEnv [] {-0-}
|
||||
|
||||
commandEnv pgf = mkCommandEnv (pgfEnv pgf) allCommands
|
||||
emptyCommandEnv = mkCommandEnv emptyPGFEnv allCommands
|
||||
multigrammar = fst . pgfenv
|
||||
concretes = snd . pgfenv
|
||||
|
||||
wordCompletion gfenv (left,right) = do
|
||||
case wc_type (reverse left) of
|
||||
CmplCmd pref
|
||||
-> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
|
||||
{-
|
||||
CmplStr (Just (Command _ opts _)) s0
|
||||
-> do mb_state0 <- try (evaluate (H.initState pgf (optLang opts) (optType opts)))
|
||||
case mb_state0 of
|
||||
Right state0 -> let (rprefix,rs) = break isSpace (reverse s0)
|
||||
s = reverse rs
|
||||
prefix = reverse rprefix
|
||||
ws = words s
|
||||
in case loop state0 ws of
|
||||
Nothing -> ret 0 []
|
||||
Just state -> let compls = H.getCompletions state prefix
|
||||
in ret (length prefix) (map (\x -> Haskeline.simpleCompletion x) (Map.keys compls))
|
||||
Left (_ :: SomeException) -> ret 0 []
|
||||
-}
|
||||
CmplOpt (Just (Command n _ _)) pref
|
||||
-> case Map.lookup n (commands cmdEnv) of
|
||||
Just inf -> do let flg_compls = [Haskeline.Completion ('-':flg++"=") ('-':flg) False | (flg,_) <- flags inf, isPrefixOf pref flg]
|
||||
opt_compls = [Haskeline.Completion ('-':opt) ('-':opt) True | (opt,_) <- options inf, isPrefixOf pref opt]
|
||||
ret (length pref+1)
|
||||
(flg_compls++opt_compls)
|
||||
Nothing -> ret (length pref) []
|
||||
CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i
|
||||
-> Haskeline.completeFilename (left,right)
|
||||
|
||||
CmplIdent _ pref
|
||||
-> case mb_pgf of
|
||||
Just pgf -> ret (length pref)
|
||||
[Haskeline.simpleCompletion name
|
||||
| name <- C.functions pgf,
|
||||
isPrefixOf pref name]
|
||||
_ -> ret (length pref) []
|
||||
|
||||
_ -> ret 0 []
|
||||
where
|
||||
mb_pgf = multigrammar cmdEnv
|
||||
cmdEnv = commandenv gfenv
|
||||
{-
|
||||
optLang opts = valStrOpts "lang" (head $ Map.keys (concretes cmdEnv)) opts
|
||||
optType opts =
|
||||
let str = valStrOpts "cat" (H.showCId $ H.lookStartCat pgf) opts
|
||||
in case H.readType str of
|
||||
Just ty -> ty
|
||||
Nothing -> error ("Can't parse '"++str++"' as type")
|
||||
|
||||
loop ps [] = Just ps
|
||||
loop ps (t:ts) = case H.nextState ps (H.simpleParseInput t) of
|
||||
Left es -> Nothing
|
||||
Right ps -> loop ps ts
|
||||
-}
|
||||
ret len xs = return (drop len left,xs)
|
||||
|
||||
|
||||
data CompletionType
|
||||
= CmplCmd Ident
|
||||
| CmplStr (Maybe Command) String
|
||||
| CmplOpt (Maybe Command) Ident
|
||||
| CmplIdent (Maybe Command) Ident
|
||||
deriving Show
|
||||
|
||||
wc_type :: String -> CompletionType
|
||||
wc_type = cmd_name
|
||||
where
|
||||
cmd_name cs =
|
||||
let cs1 = dropWhile isSpace cs
|
||||
in go cs1 cs1
|
||||
where
|
||||
go x [] = CmplCmd x
|
||||
go x (c:cs)
|
||||
| isIdent c = go x cs
|
||||
| otherwise = cmd x cs
|
||||
|
||||
cmd x [] = ret CmplIdent x "" 0
|
||||
cmd _ ('|':cs) = cmd_name cs
|
||||
cmd _ (';':cs) = cmd_name cs
|
||||
cmd x ('"':cs) = str x cs cs
|
||||
cmd x ('-':cs) = option x cs cs
|
||||
cmd x (c :cs)
|
||||
| isIdent c = ident x (c:cs) cs
|
||||
| otherwise = cmd x cs
|
||||
|
||||
option x y [] = ret CmplOpt x y 1
|
||||
option x y ('=':cs) = optValue x y cs
|
||||
option x y (c :cs)
|
||||
| isIdent c = option x y cs
|
||||
| otherwise = cmd x cs
|
||||
|
||||
optValue x y ('"':cs) = str x y cs
|
||||
optValue x y cs = cmd x cs
|
||||
|
||||
ident x y [] = ret CmplIdent x y 0
|
||||
ident x y (c:cs)
|
||||
| isIdent c = ident x y cs
|
||||
| otherwise = cmd x cs
|
||||
|
||||
str x y [] = ret CmplStr x y 1
|
||||
str x y ('\"':cs) = cmd x cs
|
||||
str x y ('\\':c:cs) = str x y cs
|
||||
str x y (c:cs) = str x y cs
|
||||
|
||||
ret f x y d = f cmd y
|
||||
where
|
||||
x1 = take (length x - length y - d) x
|
||||
x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1
|
||||
|
||||
cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
|
||||
[x] -> Just x
|
||||
_ -> Nothing
|
||||
|
||||
isIdent c = c == '_' || c == '\'' || isAlphaNum c
|
||||
@@ -1,7 +1,11 @@
|
||||
-- | GF main program (grammar compiler, interactive shell, http server)
|
||||
{-# LANGUAGE CPP #-}
|
||||
module GF.Main where
|
||||
import GF.Compiler
|
||||
import GF.Interactive
|
||||
import qualified GF.Interactive as GFI1
|
||||
#ifdef C_RUNTIME
|
||||
import qualified GF.Interactive2 as GFI2
|
||||
#endif
|
||||
import GF.Data.ErrM
|
||||
import GF.Infra.Option
|
||||
import GF.Infra.UseIO
|
||||
@@ -43,7 +47,17 @@ mainOpts opts files =
|
||||
case flag optMode opts of
|
||||
ModeVersion -> putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version ++ "\n" ++ buildInfo
|
||||
ModeHelp -> putStrLn helpMessage
|
||||
ModeInteractive -> mainGFI opts files
|
||||
ModeRun -> mainRunGFI opts files
|
||||
ModeServer port -> mainServerGFI opts port files
|
||||
ModeServer port -> GFI1.mainServerGFI opts port files
|
||||
ModeCompiler -> mainGFC opts files
|
||||
ModeInteractive -> GFI1.mainGFI opts files
|
||||
ModeRun -> GFI1.mainRunGFI opts files
|
||||
#ifdef C_RUNTIME
|
||||
ModeInteractive2 -> GFI2.mainGFI opts files
|
||||
ModeRun2 -> GFI2.mainRunGFI opts files
|
||||
#else
|
||||
ModeInteractive2 -> noCruntime
|
||||
ModeRun2 -> noCruntime
|
||||
where
|
||||
noCruntime = do ePutStrLn "GF configured without C run-time support"
|
||||
exitFailure
|
||||
#endif
|
||||
|
||||
@@ -15,7 +15,7 @@
|
||||
module PGF2 (-- * CId
|
||||
CId,
|
||||
-- * PGF
|
||||
PGF,readPGF,AbsName,abstractName,startCat,
|
||||
PGF,readPGF,AbsName,abstractName,Cat,startCat,
|
||||
-- * Concrete syntax
|
||||
ConcName,Concr,languages,parse,parseWithHeuristics,
|
||||
hasLinearization,linearize,linearizeAll,alignWords,
|
||||
|
||||
Reference in New Issue
Block a user