GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-01 23:32:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

GF shell: source commands (cc, sd, so, ss & dg) can now be used in pipes

Browse Source 
These commands are now implemented as regular commands (i.e. using the
CommandInfo data type) in the new module GF.Command.SourceCommands.

The list of commands exported from GF.Command.Commmands now called pgfCommands
instead of allCommands.

The list allCommands of all commands is now assembled
from sourceCommands, pgfCommands, commonCommands and helpCommand in
GF.Interactive.
This commit is contained in:
hallgren
2015-08-12 11:05:08 +00:00
parent 063912c386
commit 6fff2def39
6 changed files with 299 additions and 262 deletions
Download Patch File Download Diff File Expand all files Collapse all files

161
src/compiler/GF/Interactive.hs
View File

@@ -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 pgf = mkCommandEnv (pgfEnv pgf) allCommands
emptyCommandEnv = commandEnv emptyPGF
multigrammar = pgf . pgfenv
commandEnv sgr pgf = mkCommandEnv (sgr,pgfEnv pgf) allCommands
emptyCommandEnv = commandEnv emptyGrammar emptyPGF
multigrammar = pgf . snd . 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