mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-19 17:59:32 -06:00
0325f7264d
This speeds up the compilation of PhrasebookFin.pgf by 12%, mosly by speeding up calls to lookupModule in calls from lookupParamValues, in calls from allParamValues. The invariant "modules are stored in dependency order" is no longer respected! But the type MGrammar is now abstract, making it easier to maintain this or other invariants in the future.
476 lines
17 KiB
Haskell
476 lines
17 KiB
Haskell
{-# LANGUAGE ScopedTypeVariables, CPP #-}
|
|
module GFI (mainGFI,mainRunGFI,mainServerGFI) where
|
|
|
|
import GF.Command.Interpreter
|
|
import GF.Command.Importing
|
|
import GF.Command.Commands
|
|
import GF.Command.Abstract
|
|
import GF.Command.Parse
|
|
import GF.Data.ErrM
|
|
import GF.Data.Operations (chunks,err)
|
|
import GF.Grammar hiding (Ident)
|
|
import GF.Grammar.Parser (runP, pExp)
|
|
import GF.Grammar.ShowTerm
|
|
import GF.Grammar.Lookup (allOpers,allOpersTo)
|
|
import GF.Compile.Rename
|
|
import GF.Compile.Compute.Concrete (computeConcrete,checkPredefError)
|
|
import GF.Compile.TypeCheck.Concrete (inferLType,ppType)
|
|
import GF.Infra.Dependencies
|
|
import GF.Infra.CheckM
|
|
import GF.Infra.UseIO
|
|
import GF.Infra.Option
|
|
import GF.Infra.Modules (greatestResource, modules, emptyModInfo)
|
|
import GF.Infra.BuildInfo (buildInfo)
|
|
import qualified System.Console.Haskeline as Haskeline
|
|
import GF.Text.Coding
|
|
|
|
import GF.Compile.Coding
|
|
|
|
import PGF
|
|
import PGF.Data
|
|
import PGF.Macros
|
|
|
|
import Data.Char
|
|
import Data.Maybe
|
|
import Data.List(isPrefixOf,isInfixOf,partition)
|
|
import qualified Data.Map as Map
|
|
import qualified Data.ByteString.Char8 as BS
|
|
import qualified Text.ParserCombinators.ReadP as RP
|
|
import System.IO
|
|
import System.CPUTime
|
|
import System.Directory
|
|
import Control.Exception
|
|
import Control.Monad
|
|
import Data.Version
|
|
import Text.PrettyPrint (render)
|
|
import GF.System.Signal
|
|
#ifdef SERVER_MODE
|
|
import GFServer(server)
|
|
#endif
|
|
#ifdef mingw32_HOST_OS
|
|
import System.Win32.Console
|
|
import System.Win32.NLS
|
|
#endif
|
|
|
|
import Paths_gf
|
|
|
|
mainRunGFI :: Options -> [FilePath] -> IO ()
|
|
mainRunGFI opts files = shell (beQuiet opts) files
|
|
|
|
beQuiet = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet}))
|
|
|
|
mainGFI :: Options -> [FilePath] -> IO ()
|
|
mainGFI opts files = do
|
|
putStrLn welcome
|
|
shell opts files
|
|
|
|
shell opts files = loop opts =<< importInEnv emptyGFEnv opts files
|
|
|
|
#ifdef SERVER_MODE
|
|
mainServerGFI opts0 files =
|
|
server (execute1 opts) =<< importInEnv emptyGFEnv opts files
|
|
where opts = beQuiet opts0
|
|
#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 (return ()) (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 = 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 -> IO a -> IO 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 -> IO (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
|
|
"so":ws -> show_operations 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 = sourcegrammar 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 (tail (words s0))
|
|
|
|
case runP pExp (encodeUnicode utf8 s) of
|
|
Left (_,msg) -> putStrLn msg
|
|
Right t -> case checkComputeTerm sgr (unLoc (codeTerm (decodeUnicode utf8 . BS.pack) (L (0,0) t))) of
|
|
Ok x -> putStrLn $ showTerm sgr style q x
|
|
Bad s -> putStrLn $ s
|
|
continue gfenv
|
|
|
|
show_operations ws =
|
|
case greatestResource sgr of
|
|
Nothing -> putStrLn "no source grammar in scope" >> 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 (encodeUnicode utf8 (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 . GF.Compile.TypeCheck.Concrete.ppType)
|
|
let printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
|
|
mapM_ putStrLn [l | l <- printed, all (flip isInfixOf l) greps]
|
|
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 <- 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, sourcegrammar = emptySourceGrammar
|
|
}
|
|
|
|
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 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
|
|
#ifdef mingw32_HOST_OS
|
|
case cod of
|
|
'C':'P':c -> case reads c of
|
|
[(cp,"")] -> do setConsoleCP cp
|
|
setConsoleOutputCP cp
|
|
_ -> return ()
|
|
"UTF-8" -> do setConsoleCP 65001
|
|
setConsoleOutputCP 65001
|
|
_ -> return ()
|
|
#endif
|
|
enc <- mkTextEncoding cod
|
|
hSetEncoding stdin enc
|
|
hSetEncoding stdout enc
|
|
hSetEncoding stderr enc
|
|
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 (Bad "no source grammar in scope") return $ greatestResource sgr
|
|
((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
|
|
inferLType sgr [] t
|
|
t1 <- computeConcrete sgr t
|
|
checkPredefError sgr 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 <- runInterruptibly $ Haskeline.runInputT settings (Haskeline.getInputLine (prompt (commandenv gfenv)))
|
|
case res of
|
|
Left _ -> return ""
|
|
Right Nothing -> return "q"
|
|
Right (Just s) -> return s
|
|
|
|
importInEnv :: GFEnv -> Options -> [FilePath] -> IO GFEnv
|
|
importInEnv gfenv opts files
|
|
| flag optRetainResource opts =
|
|
do src <- importSource (sourcegrammar gfenv) opts files
|
|
return $ gfenv {sourcegrammar = src}
|
|
| otherwise =
|
|
do let opts' = addOptions (setOptimization OptCSE False) opts
|
|
pgf0 = multigrammar (commandenv gfenv)
|
|
pgf1 <- importGrammar pgf0 opts' files
|
|
if (verbAtLeast opts Normal)
|
|
then putStrLnFlush $ unwords $ "\nLanguages:" : map showCId (languages pgf1)
|
|
else return ()
|
|
return $ gfenv { commandenv = mkCommandEnv pgf1 }
|
|
|
|
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"
|
|
]
|
|
|
|
prompt env
|
|
| abs == wildCId = "> "
|
|
| otherwise = showCId abs ++ "> "
|
|
where
|
|
abs = abstractName (multigrammar env)
|
|
|
|
data GFEnv = GFEnv {
|
|
sourcegrammar :: SourceGrammar, -- gfo grammar -retain
|
|
commandenv :: CommandEnv,
|
|
history :: [String]--,
|
|
--cputime :: Integer
|
|
}
|
|
|
|
emptyGFEnv :: GFEnv
|
|
emptyGFEnv =
|
|
GFEnv (mGrammar [(identW,emptyModInfo)]) (mkCommandEnv emptyPGF) [] {-0-}
|
|
|
|
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 (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 = 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
|
|
-> do mb_abs <- try (evaluate (abstract pgf))
|
|
case mb_abs of
|
|
Right abs -> ret (length pref) [Haskeline.simpleCompletion name | cid <- Map.keys (funs abs), let name = showCId cid, isPrefixOf pref name]
|
|
Left (_ :: SomeException) -> ret (length pref) []
|
|
_ -> ret 0 []
|
|
where
|
|
pgf = multigrammar cmdEnv
|
|
cmdEnv = commandenv gfenv
|
|
optLang opts = valCIdOpts "lang" (head (languages pgf)) opts
|
|
optType opts =
|
|
let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts
|
|
in case readType str of
|
|
Just ty -> ty
|
|
Nothing -> error ("Can't parse '"++str++"' as type")
|
|
|
|
loop ps [] = Just ps
|
|
loop ps (t:ts) = case nextState ps (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
|