diff options
Diffstat (limited to 'src/compiler/GF/Interactive.hs')
| -rw-r--r-- | src/compiler/GF/Interactive.hs | 161 |
1 files changed, 25 insertions, 136 deletions
diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index d0311479f..216c5f1e2 100644 --- a/src/compiler/GF/Interactive.hs +++ b/src/compiler/GF/Interactive.hs @@ -5,21 +5,15 @@ import Prelude hiding (putStrLn,print) import qualified Prelude as P(putStrLn) import GF.Command.Interpreter(CommandEnv(..),pgfenv,commands,mkCommandEnv,interpretCommandLine) --import GF.Command.Importing(importSource,importGrammar) -import GF.Command.Commands(flags,options,PGFEnv,pgf,pgfEnv,allCommands) +import GF.Command.Commands(flags,options,PGFEnv,pgf,pgfEnv,pgfCommands) +import GF.Command.CommonCommands(commonCommands,extend) +import GF.Command.SourceCommands(sourceCommands) +import GF.Command.CommandInfo(mapCommandEnv) +import GF.Command.Help(helpCommand) import GF.Command.Abstract import GF.Command.Parse(readCommandLine,pCommand) -import GF.Data.Operations (Err(..),chunks,err,raise,done) +import GF.Data.Operations (Err(..),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 @@ -32,17 +26,14 @@ import PGF import PGF.Internal(abstract,funs,lookStartCat,emptyPGF) import Data.Char -import Data.List(nub,isPrefixOf,isInfixOf,partition) +import Data.List(isPrefixOf) 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 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) @@ -123,18 +114,14 @@ 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 + -- special commands {-"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 + -- cc, sd, so, ss and dg are now in GF.Commands.SourceCommands "eh":ws -> eh ws "i" :ws -> import_ ws -- other special commands, working on GFEnv @@ -152,7 +139,6 @@ execute1 opts gfenv0 s0 = 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 @@ -169,98 +155,6 @@ execute1 opts gfenv0 s0 = 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 @@ -278,9 +172,7 @@ execute1 opts gfenv0 s0 = return gfenv continue gfenv' - empty = continue $ gfenv { - commandenv=emptyCommandEnv, grammar = emptyGrammar - } + empty = continue $ gfenv { commandenv=emptyCommandEnv } define_command (f:ws) = case readCommandLine (unwords ws) of @@ -327,13 +219,6 @@ execute1 opts gfenv0 s0 = 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" @@ -354,11 +239,11 @@ importInEnv gfenv opts files | flag optRetainResource opts = do src <- importSource opts files pgf <- lazySIO importPGF -- duplicates some work, better to link src - return $ gfenv {grammar = src, retain=True, - commandenv = commandEnv pgf } + return $ gfenv {retain=True, commandenv = commandEnv src pgf } | otherwise = do pgf1 <- importPGF - return $ gfenv { commandenv = commandEnv pgf1 } + return $ gfenv { retain=False, + commandenv = commandEnv emptyGrammar pgf1 } where importPGF = do let opts' = addOptions (setOptimization OptCSE False) opts @@ -383,18 +268,22 @@ prompt env abs = abstractName (multigrammar (commandenv env)) data GFEnv = GFEnv { - grammar :: Grammar, -- gfo grammar -retain - retain :: Bool, -- grammar was imported with -retain flag - commandenv :: CommandEnv PGFEnv, - history :: [String] + retain :: Bool, -- grammar was imported with -retain flag + commandenv :: CommandEnv (Grammar,PGFEnv), + history :: [String] } emptyGFEnv :: GFEnv -emptyGFEnv = GFEnv emptyGrammar False emptyCommandEnv [] {-0-} +emptyGFEnv = GFEnv False emptyCommandEnv [] {-0-} + +commandEnv sgr pgf = mkCommandEnv (sgr,pgfEnv pgf) allCommands +emptyCommandEnv = commandEnv emptyGrammar emptyPGF +multigrammar = pgf . snd . pgfenv -commandEnv pgf = mkCommandEnv (pgfEnv pgf) allCommands -emptyCommandEnv = commandEnv emptyPGF -multigrammar = pgf . pgfenv +allCommands = + extend (fmap (mapCommandEnv snd) pgfCommands) [helpCommand allCommands] + `Map.union` (fmap (mapCommandEnv fst) sourceCommands) + `Map.union` commonCommands wordCompletion gfenv (left,right) = do case wc_type (reverse left) of |