Founding the newly structured GF2.0 cvs archive.

1 files changed, 292 insertions, 0 deletions

diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs
new file mode 100644
index 000000000..6e4afe88f
--- /dev/null
+++ b/src/GF/Shell.hs
@@ -0,0 +1,292 @@
+module Shell where
+
+--- abstract away from these?
+import Str
+import qualified Grammar as G
+import qualified Ident as I
+import qualified Compute as Co
+import qualified GFC
+import Values
+import GetTree
+
+import API
+import IOGrammar
+import Compile
+---- import GFTex
+-----import TeachYourself -- also a subshell
+
+import ShellState
+import Option
+import Information
+import HelpFile
+import PrOld
+import PrGrammar
+
+import Monad (foldM)
+import System (system)
+
+import Operations
+import UseIO
+import UTF8 (encodeUTF8)
+
+
+---- import qualified GrammarToGramlet as Gr
+---- import qualified GrammarToCanonXML2 as Canon
+
+-- AR 18/4/2000 - 7/11/2001
+
+type SrcTerm = G.Term -- term as returned by the command parser
+
+data Command =
+   CImport FilePath
+ | CRemoveLanguage Language
+ | CEmptyState
+ | CTransformGrammar FilePath
+ | CConvertLatex FilePath
+
+ | CLinearize [()] ---- parameters
+ | CParse
+ | CTranslate Language Language
+ | CGenerateRandom Int
+ | CPutTerm
+ | CWrapTerm Ident
+ | CMorphoAnalyse
+ | CTestTokenizer
+ | CComputeConcrete I.Ident String
+
+ | CTranslationQuiz Language Language
+ | CTranslationList Language Language Int
+ | CMorphoQuiz
+ | CMorphoList Int
+
+ | CReadFile   FilePath
+ | CWriteFile  FilePath
+ | CAppendFile FilePath
+ | CSpeakAloud
+ | CPutString
+ | CShowTerm
+ | CSystemCommand String
+
+ | CSetFlag
+ | CSetLocalFlag Language
+
+ | CPrintGrammar
+ | CPrintGlobalOptions
+ | CPrintLanguages
+ | CPrintInformation I.Ident
+ | CPrintMultiGrammar
+ | CPrintGramlet 
+ | CPrintCanonXML
+ | CPrintCanonXMLStruct 
+ | CPrintHistory
+ | CHelp
+
+ | CImpure ImpureCommand
+
+ | CVoid
+
+-- to isolate the commands that are executed on top level
+data ImpureCommand = 
+    ICQuit | ICExecuteHistory FilePath | ICEarlierCommand Int
+  | ICEditSession | ICTranslateSession
+
+type CommandLine = (CommandOpt, CommandArg,  [CommandOpt])
+
+type CommandOpt = (Command, Options)
+
+type HState  = (ShellState,([String],Integer)) -- history & CPU
+
+type ShellIO = (HState, CommandArg) -> IO (HState, CommandArg)
+
+initHState :: ShellState -> HState
+initHState st = (st,([],0))
+
+cpuHState (_,(_,i)) = i
+optsHState (st,_) = globalOptions st
+putHStateCPU cpu (st,(h,_)) = (st,(h,cpu))
+updateHistory s (st,(h,cpu)) = (st,(s:h,cpu))
+earlierCommandH (_,(h,_)) = ((h ++ repeat "") !!) -- empty command if index over
+
+execLinesH :: String -> [CommandLine] -> HState -> IO HState
+execLinesH s cs hst@(st, (h, _)) = do
+  (_,st') <- execLines True cs hst
+  cpu     <- prOptCPU (optsHState st') (cpuHState hst)
+  return $ putHStateCPU cpu $ updateHistory s st'
+
+ifImpure :: [CommandLine] -> Maybe (ImpureCommand,Options)
+ifImpure cls = foldr (const . Just) Nothing [(c,os) | ((CImpure c,os),_,_) <- cls]
+
+-- the main function: execution of commands. put :: Bool forces immediate output
+
+-- command line with consecutive (;) commands: no value transmitted
+execLines :: Bool -> [CommandLine] -> HState -> IO ([String],HState)
+execLines put cs st = foldM (flip (execLine put)) ([],st) cs
+
+-- command line with piped (|) commands: no value returned
+execLine :: Bool -> CommandLine -> ([String],HState) -> IO ([String],HState)
+execLine put (c@(co, os), arg, cs) (outps,st) = do
+  (st',val) <- execC c (st, arg)
+  let tr = oElem doTrace os || null cs    -- option -tr leaves trace in pipe
+      utf = if (oElem useUTF8 os) then encodeUTF8 else id 
+      outp = if tr then [utf (prCommandArg val)] else []
+  if put then mapM_ putStrLnFlush outp else return ()
+  execs cs val (if put then [] else outps ++ outp, st')
+ where
+    execs []     arg st = return st
+    execs (c:cs) arg st = execLine put (c, arg, cs) st
+
+-- individual commands possibly piped: value returned; this is not a state monad
+execC :: CommandOpt -> ShellIO
+execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of
+
+  --- read old GF and write into files; no update of st yet
+  CImport file | oElem showOld opts -> useIOE sa $ batchCompileOld file >> return sa
+
+  CImport file -> useIOE sa $ do
+    st <- shellStateFromFiles opts st file
+    ioeIO $ changeState (const st) sa --- \ ((_,h),a) -> ((st,h), a))
+  CEmptyState         -> changeState reinitShellState sa
+
+{-
+  CRemoveLanguage lan -> changeState (removeLanguage lan) sa
+  CTransformGrammar file -> do
+    s <- transformGrammarFile opts file
+    returnArg (AString s) sa
+  CConvertLatex file -> do
+    s <- readFileIf file
+    returnArg (AString (convertGFTex s)) sa 
+-}
+  CPrintHistory -> (returnArg $ AString $ unlines $ reverse h) sa
+  -- good to have here for piping; eh and ec must be done on outer level
+
+  CLinearize [] -> changeArg (opTS2CommandArg (optLinearizeTreeVal opts gro) . s2t) sa
+----  CLinearize m -> changeArg (opTS2CommandArg (optLinearizeArgForm opts gro m)) sa
+
+  CParse     -> case optParseArgErrMsg opts gro (prCommandArg a) of
+    Ok (ts,msg) -> putStrLnFlush msg >> changeArg (const $ ATrms ts) sa
+    Bad msg -> changeArg (const $ AError msg) sa
+
+  CTranslate il ol -> do
+    let a' = opST2CommandArg (optParseArgErr opts (sgr il)) a
+    returnArg (opTS2CommandArg (optLinearizeTreeVal opts (sgr ol)) a') sa
+  CGenerateRandom n -> do
+    ts <- randomTreesIO opts gro (optIntOrN opts flagNumber n)
+    returnArg (ATrms ts) sa
+-----  CPutTerm -> changeArg (opTT2CommandArg (optTermCommand opts gro) . s2t) sa
+-----  CWrapTerm f -> changeArg (opTT2CommandArg (return . wrapByFun opts gro f)) sa
+  CMorphoAnalyse -> changeArg (AString . morphoAnalyse opts gro . prCommandArg) sa
+  CTestTokenizer -> changeArg (AString . optTokenizer opts gro . prCommandArg) sa
+
+  CComputeConcrete m t -> 
+    justOutput (putStrLn (err id prt (
+                string2srcTerm src m t >>= Co.computeConcrete src))) sa
+
+{- ----
+  CTranslationQuiz il ol -> justOutput (teachTranslation opts (sgr il) (sgr ol)) sa
+  CTranslationList il ol n -> do 
+    qs <- transTrainList opts (sgr il) (sgr ol) (toInteger n)
+    returnArg (AString $ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa
+
+  CMorphoQuiz -> justOutput (teachMorpho opts gro) sa
+  CMorphoList n -> do 
+    qs <- useIOE [] $ morphoTrainList opts gro (toInteger n)
+    returnArg (AString $ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa
+-}
+  CReadFile file   -> returnArgIO   (readFileIf file >>= return . AString) sa
+  CWriteFile file  -> justOutputArg (writeFile file) sa
+  CAppendFile file -> justOutputArg (appendFile file) sa
+  CSpeakAloud      -> justOutputArg (speechGenerate opts) sa
+  CSystemCommand s -> justOutput    (system s >> return ()) sa
+-----  CPutString       -> changeArg     (opSS2CommandArg (optStringCommand opts gro)) sa
+-----  CShowTerm        -> changeArg     (opTS2CommandArg (optPrintTerm opts gro) . s2t) sa
+
+  CSetFlag           -> changeState (addGlobalOptions opts0) sa
+---- deprec!  CSetLocalFlag lang -> changeState (addLocalOptions lang opts0) sa
+
+  CHelp              -> returnArg   (AString txtHelpFile) sa
+
+  CPrintGrammar
+    | oElem showOld opts -> returnArg (AString $ printGrammarOld (canModules st)) sa
+    | otherwise -> returnArg (AString (optPrintGrammar opts gro)) sa
+  CPrintGlobalOptions -> justOutput (putStrLn $ prShellStateInfo st) sa
+  CPrintInformation c -> justOutput (useIOE () $ showInformation opts st c) sa
+  CPrintLanguages     -> justOutput 
+                         (putStrLn $ unwords $ map prLanguage $ allLanguages st) sa
+----  CPrintMultiGrammar  -> returnArg (AString (prMultiGrammar opts st)) sa
+----  CPrintGramlet       -> returnArg (AString (Gr.prGramlet st)) sa
+----  CPrintCanonXML      -> returnArg (AString (Canon.prCanonXML st False)) sa
+----  CPrintCanonXMLStruct -> returnArg (AString (Canon.prCanonXML st True)) sa
+  _ -> justOutput (putStrLn "command not understood") sa
+
+ where
+   sgr = stateGrammarOfLang st
+   gro = grammarOfOptState opts st
+   opts = addOptions opts0 (globalOptions st)
+   src = srcModules st
+
+   s2t a = case a of
+     ASTrm s  -> err AError (ATrms . return) $ string2treeErr gro s
+     _ -> a
+
+
+-- commands either change the state or process the argument, but not both
+-- some commands just do output
+
+changeState :: ShellStateOper -> ShellIO
+changeState f ((st,h),a) = return ((f st,h), a)
+
+changeArg :: (CommandArg -> CommandArg) -> ShellIO
+changeArg f (st,a) = return (st, f a)
+
+changeArgMsg :: (CommandArg -> (CommandArg,String)) -> ShellIO
+changeArgMsg f (st,a) = do
+  let (b,msg) = f a
+  putStrLnFlush msg
+  return (st, b)
+
+returnArg :: CommandArg -> ShellIO
+returnArg = changeArg . const
+
+returnArgIO :: IO CommandArg -> ShellIO
+returnArgIO io (st,_) = io >>= (\a -> return (st,a))
+
+justOutputArg :: (String -> IO ()) -> ShellIO
+justOutputArg f sa@(st,a) = f (prCommandArg a) >> return (st, AUnit)
+
+justOutput :: IO () -> ShellIO
+justOutput = justOutputArg . const
+
+-- type system for command arguments; instead of plain strings...
+
+data CommandArg = 
+   AError  String 
+ | ATrms   [Tree] 
+ | ASTrm   String   -- to receive from parser 
+ | AStrs   [Str] 
+ | AString String 
+ | AUnit 
+  deriving (Eq, Show)
+
+prCommandArg :: CommandArg -> String
+prCommandArg arg = case arg of
+  AError s   -> s
+  AStrs ss   -> sstrV ss
+  AString s  -> s
+  ATrms []   -> "no tree found"
+  ATrms tt   -> unlines $ map prt_Tree tt
+  ASTrm s    -> s
+  AUnit      -> ""
+
+opSS2CommandArg :: (String -> String) -> CommandArg -> CommandArg
+opSS2CommandArg f = AString . f . prCommandArg
+
+opST2CommandArg :: (String -> Err [Tree]) -> CommandArg -> CommandArg
+opST2CommandArg f = err AError ATrms . f . prCommandArg
+
+opTS2CommandArg :: (Tree -> String) -> CommandArg -> CommandArg
+opTS2CommandArg f (ATrms ts) = AString $ unlines $ map f ts
+opTS2CommandArg _ _ = AError ("expected term")
+
+opTT2CommandArg :: (Tree -> [Tree]) -> CommandArg -> CommandArg
+opTT2CommandArg f (ATrms ts) = ATrms $ concat $ map f ts
+opTT2CommandArg _ _ = AError ("expected term")