path: root/src/GF/Shell.hs

----------------------------------------------------------------------
-- |
-- Module      : Shell
-- Maintainer  : AR
-- Stability   : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/07 20:15:05 $ 
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.50 $
--
-- GF shell command interpreter.
-----------------------------------------------------------------------------

module GF.Shell where

--- abstract away from these?
import GF.Data.Str
import qualified GF.Grammar.Grammar as G
import qualified GF.Infra.Ident as I
import qualified GF.Grammar.Compute as Co
import qualified GF.Compile.CheckGrammar as Ch
import qualified GF.Grammar.Lookup as L
import qualified GF.Canon.GFC as GFC
import qualified GF.Canon.Look as Look
import qualified GF.Canon.CMacros as CMacros
import qualified GF.Compile.GrammarToCanon as GrammarToCanon
import GF.Grammar.Values
import GF.UseGrammar.GetTree
import GF.UseGrammar.Treebank

import GF.Shell.ShellCommands

import GF.Visualization.VisualizeGrammar (visualizeCanonGrammar, visualizeSourceGrammar)
import GF.Visualization.VisualizeTree (visualizeTrees)
import GF.API
import GF.API.IOGrammar
import GF.Compile.Compile
---- import GFTex
import GF.Shell.TeachYourself -- also a subshell

import GF.UseGrammar.Randomized ---
import GF.UseGrammar.Editing (goFirstMeta) ---

import GF.Probabilistic.Probabilistic

import GF.Compile.ShellState
import GF.Infra.Option
import GF.UseGrammar.Information
import GF.Shell.HelpFile
import GF.Compile.PrOld
import GF.Grammar.PrGrammar

import Control.Monad (foldM,liftM)
import System (system)
import System.IO (hPutStrLn, stderr)
import System.Random (newStdGen) ----
import Data.List (nub,isPrefixOf)
import GF.Data.Zipper ----

import GF.Data.Operations
import GF.Infra.UseIO
import GF.Text.UTF8 (encodeUTF8)
import Data.Char (isDigit)
import Data.Maybe (fromMaybe)

import GF.System.Signal (runInterruptibly)

---- import qualified GrammarToGramlet as Gr
---- import qualified GrammarToCanonXML2 as Canon

-- AR 18/4/2000 - 7/11/2001

-- data Command moved to ShellCommands. AR 27/5/2004

type CommandLine = (CommandOpt, CommandArg,  [CommandOpt])

-- | term as returned by the command parser
type SrcTerm = G.Term 

-- | history & CPU
type HState  = (ShellState,([String],Integer,ShMacros,ShTerms)) 

type ShMacros = [(String,[String])] -- dc %c = ... #1 ... #2 ...
type ShTerms  = [(String,Tree)]     -- dt $e = f ...

type ShellIO = (HState, CommandArg) -> IO (HState, CommandArg)

initHState :: ShellState -> HState
initHState st = (st,([],0,[],[]))

cpuHState :: HState -> Integer
cpuHState (_,(_,i,_,_)) = i

optsHState :: HState -> Options
optsHState (st,_) = globalOptions st

putHStateCPU :: Integer -> HState -> HState
putHStateCPU cpu (st,(h,_,c,t)) = (st,(h,cpu,c,t))

updateHistory :: String -> HState -> HState
updateHistory s (st,(h,cpu,c,t)) = (st,(s:h,cpu,c,t))

addShMacro :: (String,[String]) -> HState -> HState
addShMacro m (st,(h,cpu,c,t)) = (st,(h,cpu,m:c,t))

addShTerm :: (String,Tree) -> HState -> HState
addShTerm m (st,(h,cpu,c,t)) = (st,(h,cpu,c,m:t))

resolveShMacro :: HState -> String -> [String] -> [String]
resolveShMacro st@(_,(_,_,cs,_)) c args = case lookup c cs of
  Just def -> map subst def
  _ -> [] ----
 where
   subst s = case s of
     "#1" -> unwords args
     _ -> s
 --- so far only one arg allowed - how to determine arg boundaries?
{-
   subst s = case s of
     '#':d@(_:_) | all isDigit d -> 
        let i = read d in if i > lg then s else args !! (i-1) -- #1 is first
     _ -> s
   lg = length args
-}

lookupShTerm :: HState -> String -> Maybe Tree
lookupShTerm st@(_,(_,_,_,ts)) c = lookup c ts

txtHelpMacros :: HState -> String
txtHelpMacros (_,(_,_,cs,ts)) = unlines $
  ["Defined commands:",""] ++
  [c +++ "=" +++ unwords def | (c,def) <- cs] ++
  ["","Defined terms:",""] ++
  [c +++ "=" +++ prt_ def | (c,def) <- ts]

-- | empty command if index over
earlierCommandH :: HState -> Int -> String
earlierCommandH (_,(h,_,_,_)) = ((h ++ repeat "") !!) 

execLinesH :: String -> [CommandLine] -> HState -> IO HState
execLinesH s cs hst@(st, (h,_,_,_)) = do
  (_,st') <- execLinesI True cs hst
  cpu     <- prOptCPU (optsHState st') (cpuHState hst)
  return $ putHStateCPU cpu $ updateHistory s st'

-- | Like 'execLines', but can be interrupted by SIGINT.
execLinesI :: Bool -> [CommandLine] -> HState -> IO ([String],HState)
execLinesI put cs st = 
    do
    x <- runInterruptibly (execLines put cs st)
    case x of
           Left ex -> do hPutStrLn stderr ""
                         hPutStrLn stderr $ show ex
                         return ([],st)
           Right y -> return y

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@(sh@(st,(h,_,_,_)),a) = checkOptions st co >> case comm of

  CImport file | oElem fromExamples opts -> do
    es <- liftM nub $ getGFEFiles opts file
    system $ "gf -examples" +++ unlines es
    execC (comm, removeOption fromExamples opts) sa
  CImport file -> useIOE sa $ do
    st1 <- shellStateFromFiles opts st file
    ioeIO $ changeState (const st1) sa --- \ ((_,h),a) -> ((st,h), a))

  CEmptyState    -> changeState reinitShellState sa
  CChangeMain ma -> changeStateErr (changeMain ma) sa
  CStripState    -> changeState purgeShellState sa

  CRemoveLanguage lan -> changeState (removeLang 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

  CDefineCommand c args -> return (addShMacro (c,args) sh, AUnit)
  CDefineTerm c -> do 
    let 
      a' = case a of
        ASTrm _ -> s2t a
        AString _ -> s2t a
        _ -> a
    case a' of
      ATrms [trm] -> return (addShTerm (c,trm) sh, AUnit) 
      _ ->  returnArg (AError "illegal term definition") sa

  CLinearize [] 
    | oElem showMulti opts -> 
       changeArg (opTS2CommandArg (unlines. linearizeToAll
          (allStateGrammars st)) . s2t) sa 
    | otherwise -> changeArg (opTS2CommandArg (optLinearizeTreeVal opts gro) . s2t) sa
----  CLinearize m -> changeArg (opTS2CommandArg (optLinearizeArgForm opts gro m)) sa

  CParse 
----    | oElem showMulti opts -> do
    | oElem byLines opts -> do
        let ss = (if oElem showAll opts then id else filter (not . null)) $ 
                     lines $ prCommandArg a
        mts <- mapM parse ss
        let a' = ATrms [t | (_,ATrms ts) <- mts, t <- ts]
        changeArg (const a') sa
    | otherwise -> parse $ prCommandArg a
   where 
      parse x = do
       warnDiscont opts 
       let p = optParseArgErrMsg opts gro x
       case p of
         Ok (ts,msg) 
           | oElem (iOpt "prob") opts -> do
                let probs = stateProbs gro 
                let tps = rankByScore [(t,computeProbTree probs t) | t <- ts]
                putStrLnFlush msg
                mapM_ putStrLnFlush [show p | (t,p) <- tps]
                changeArg (const $ ATrms (map fst tps)) sa
           | otherwise -> putStrLnFlush msg >> changeArg (const $ ATrms ts) sa
         Bad msg -> changeArg (const $ AError (msg +++ "input" +++ x)) sa

  CTranslate il ol -> do
    let a' = opST2CommandArg (optParseArgErr opts (sgr il)) a
    returnArg (opTS2CommandArg (optLinearizeTreeVal opts (sgr ol)) a') sa

  CGenerateRandom | oElem showCF opts || oElem (iOpt "prob") opts -> do
    let probs = stateProbs gro 
    let cat = firstAbsCat opts gro
    let n = optIntOrN opts flagNumber 1
    gen    <- newStdGen
    let ts = take n $ generateRandomTreesProb opts gen cgr probs cat
    returnArg (ATrms (map (term2tree gro) ts)) sa

  CGenerateRandom -> do
    let 
      a' = case a of
        ASTrm _ -> s2t a
        AString _ -> s2t a
        _ -> a
    case a' of
      ATrms (trm:_) -> case tree2exp trm of
        G.EInt _ -> do
          putStrLn "Warning: Number argument deprecated, use gr -number=n instead"
          ts <- randomTreesIO opts gro (optIntOrN opts flagNumber 1)
          returnArg (ATrms ts) sa
        _ -> do
            g    <- newStdGen
            case (goFirstMeta (tree2loc trm) >>= refineRandom g 41 cgr) of
              Ok trm' -> returnArg (ATrms [loc2tree trm']) sa
              Bad s   -> returnArg (AError s) sa
      _ -> do
        ts <- randomTreesIO opts gro (optIntOrN opts flagNumber 1)
        returnArg (ATrms ts) sa
  CGenerateTrees -> do
    let 
      a' = case a of
        ASTrm _ -> s2t a
        AString _ -> s2t a
        _ -> a
      mt = case a' of
        ATrms (tr:_) -> Just tr
        _ -> Nothing
    returnArg (ATrms $ generateTrees opts gro mt) sa

  CTreeBank | oElem doCompute opts -> do -- -c
    let bank = prCommandArg a
    returnArg (AString $ unlines $ testMultiTreebank opts st bank) sa
  CTreeBank | oElem getTrees opts -> do -- -trees
    let bank  = prCommandArg a
        tes   = map (string2treeErr gro) $ treesTreebank opts bank
        terms = [t | Ok t <- tes] 
    returnArg (ATrms terms) sa
  CTreeBank -> do
    let ts = strees $ s2t $ snd sa
        comm = "command" ----
    returnArg (AString $ unlines $ mkMultiTreebank opts st comm ts) sa

  CLookupTreebank -> do
    let tbs = treebanks st
    let s   = prCommandArg a
    if null tbs 
      then returnArg (AError "no treebank") sa
      else do
        let tbi = maybe (fst $ head tbs) I.identC (getOptVal opts (aOpt "treebank"))
        case lookup tbi tbs of
          Nothing -> returnArg (AError ("no treebank" +++ prt tbi)) sa
          Just tb -> case () of
            _ | oElem (iOpt "strings") opts -> do
              returnArg (AString $ unlines $ map fst $ assocsTreebank tb) sa
            _ | oElem (iOpt "raw") opts -> do
              returnArg (AString $ unlines $ lookupTreebank tb s) sa
            _ | oElem (iOpt "assocs") opts -> do
              returnArg (AString $ unlines $ map printAssoc $ assocsTreebank tb) sa
            _ -> do            
              let tes = map (string2treeErr gro) $ lookupTreebank tb s
                  terms = [t | Ok t <- tes]
              returnArg (ATrms terms) sa

  CShowTreeGraph | oElem emitCode opts -> do -- -o
    returnArg (AString $ visualizeTrees opts $ strees $ s2t a) sa
  CShowTreeGraph  -> do
    let g0 = writeFile "grphtmp.dot" $ visualizeTrees opts $ strees $ s2t a
        g1 = system "dot -Tps grphtmp.dot >grphtmp.ps" 
        g2 = system "gv grphtmp.ps &" 
        g3 = return () ---- system "rm -f grphtmp.*"
    justOutput opts (g0 >> g1 >> g2 >> g3 >> return ()) sa

  CPutTerm -> changeArg (opTT2CommandArg (return . optTermCommand opts gro) . s2t) sa

  CWrapTerm f -> changeArg (opTT2CommandArg (return . return . wrapByFun opts gro f) . s2t) sa
  CApplyTransfer f -> changeArg (opTT2CommandArg (applyTransfer opts gro transfs f) . s2t) sa
  CMorphoAnalyse -> changeArg (AString . morphoAnalyse opts gro . prCommandArg) sa
  CTestTokenizer -> changeArg (AString . optTokenizer opts gro . prCommandArg) sa

  CComputeConcrete t -> do
    m <- return $
         maybe (I.identC "?") id $  -- meaningful if no opers in t 
           maybe (resourceOfShellState st) (return . I.identC) $ -- topmost res
             getOptVal opts useResource             -- flag -res=m
    justOutput opts (putStrLn (err id (prt . stripTerm) (
                string2srcTerm src m t >>= 
                Ch.justCheckLTerm src  >>=
                Co.computeConcrete src))) sa
---                Co.computeConcreteRec src))) sa
  CShowOpers t -> do
    m <- return $
         maybe (I.identC "?") id $  -- meaningful if no opers in t 
           maybe (resourceOfShellState st) (return . I.identC) $ -- topmost res
             getOptVal opts useResource             -- flag -res=m
    justOutput opts (putStrLn (err id (unlines . map prOperSignature) (
                string2srcTerm src m t >>= (\t' -> 
                Co.computeConcrete src t' >>=  (\v -> 
                return (L.opersForType src t' v)))))) sa


  CTranslationQuiz il ol -> do
    warnDiscont opts 
    justOutput opts (teachTranslation opts (sgr il) (sgr ol)) sa
  CTranslationList il ol -> do
    warnDiscont opts
    let n = optIntOrN opts flagNumber 10 
    qs <- transTrainList opts (sgr il) (sgr ol) (toInteger n)
    let hdr = unlines ["# From: " ++ prIdent il,
                       "# To: " ++ prIdent ol]
    returnArg (AString $ hdr ++++ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa

  CMorphoQuiz -> do
    warnDiscont opts 
    justOutput opts (teachMorpho opts gro) sa
  CMorphoList -> do
    let n = optIntOrN opts flagNumber 10  
    warnDiscont opts 
    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 opts (writeFile file) sa
  CAppendFile file -> justOutputArg opts (appendFile file) sa
  CSpeakAloud      -> justOutputArg opts (speechGenerate opts) sa
  CSpeechInput     -> returnArgIO (speechInput opts gro >>= return . AString . unlines) sa
  CSystemCommand s -> case a of
    AUnit -> justOutput opts (system s >> return ()) sa
    _     -> systemArg  opts a s sa 
  CPutString       -> changeArg    (opSS2CommandArg (optStringCommand opts gro)) sa
-----  CShowTerm        -> changeArg  (opTS2CommandArg (optPrintTerm opts gro) . s2t) sa
  CGrep ms -> changeArg (AString . unlines . filter (grep ms) . lines . prCommandArg) sa


  CSetFlag           -> changeState (addGlobalOptions opts0) sa
---- deprec!  CSetLocalFlag lang -> changeState (addLocalOptions lang opts0) sa

  CHelp (Just c) -> returnArg   (AString (txtHelpCommand c)) sa
  CHelp _ -> case opts0 of
    Opts [o] | o == showAll  -> returnArg   (AString txtHelpFile) sa
    Opts [o] | o == showDefs -> returnArg   (AString (txtHelpMacros sh)) sa
    Opts [o]        -> returnArg   (AString (txtHelpCommand ('-':prOpt o))) sa
    _               -> returnArg   (AString txtHelpFileSummary) sa

  CPrintGrammar       -> returnArg (AString (optPrintGrammar opts gro)) sa
  CPrintGlobalOptions -> justOutput opts (putStrLn  $ prShellStateInfo st) sa
  CPrintInformation c -> justOutput opts (useIOE () $ showInformation opts st c) sa
  CPrintLanguages     -> justOutput opts 
                         (putStrLn $ unwords $ map prLanguage $ allLanguages st) sa
  CPrintMultiGrammar  -> do
    sa' <- changeState purgeShellState sa
    returnArg (AString (optPrintMultiGrammar opts cgr)) sa'
  CShowGrammarGraph  -> do
    ---- sa' <- changeState purgeShellState sa
    let g0 = writeFile "grphtmp.dot" $ visualizeCanonGrammar opts cgr
        g1 = system "dot -Tps grphtmp.dot >grphtmp.ps" 
        g2 = system "gv grphtmp.ps &" 
        g3 = return () ---- system "rm -f grphtmp.*"
    justOutput opts (g0 >> g1 >> g2 >> g3 >> return ()) sa
  CPrintSourceGrammar -> 
      returnArg (AString (visualizeSourceGrammar src)) 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 opts (putStrLn "command not understood") sa

 where
   sgr = stateGrammarOfLang st
   gro = grammarOfOptState opts st
   opts = addOptions opts0 (globalOptions st)
   src = srcModules st
   cgr = canModules st

   transfs = transfers st

   s2t a = case a of
     ASTrm ('$':c) -> maybe (AError "undefined term") (ATrms . return) $ lookupShTerm sh c
     ASTrm s  -> err AError (ATrms . return) $ string2treeErr gro s
     AString s  -> err AError (ATrms . return) $ string2treeErr gro s
     _ -> a

   strees a = case a of
     ATrms ts -> ts
     _ -> [] 

   warnDiscont os = err putStrLn id $ do
     let c0 = firstAbsCat os gro
     c <- GrammarToCanon.redQIdent c0
     lang <- maybeErr "no concrete" $ languageOfOptState os st
     t <- return $ errVal CMacros.defLinType $ Look.lookupLincat cgr $ CMacros.redirectIdent lang c
     return $ if CMacros.isDiscontinuousCType t 
       then (putStrLn ("Warning: discontinuous category" +++ prt_ c))
       else (return ())

   grep ms s = (if oElem invertGrep opts then not else id) $ grepv ms s --- -v
   grepv ms s = case s of
     _:cs -> isPrefixOf ms s || grepv ms cs
     _ -> isPrefixOf ms s

-- 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)

changeStateErr :: ShellStateOperErr -> ShellIO
changeStateErr f ((st,h),a) = case f st of
  Ok st' -> return ((st',h), a)
  Bad s  -> return ((st, h),AError s)

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 :: Options -> (String -> IO ()) -> ShellIO
justOutputArg opts f sa@(st,a) = f (utf (prCommandArg a)) >> return (st, AUnit) 
 where
   utf = if (oElem useUTF8 opts) then encodeUTF8 else id

justOutput :: Options -> IO () -> ShellIO
justOutput opts = justOutputArg opts . const

systemArg :: Options -> CommandArg -> String -> ShellIO
systemArg _ cont syst sa = do
  writeFile tmpi $ prCommandArg cont
  system $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo 
  s <- readFile tmpo
  returnArg (AString s) sa
 where
   tmpi = "_tmpi" ---
   tmpo = "_tmpo"

-- | 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 s) = AError ("expected term, but got error:" ++++ s)
opTS2CommandArg _ a = AError ("expected term, but got:" ++++ prCommandArg a)

opTT2CommandArg :: (Tree -> Err [Tree]) -> CommandArg -> CommandArg
opTT2CommandArg f (ATrms ts) = err AError (ATrms . concat) $ mapM f ts
opTT2CommandArg _ (AError s) = AError ("expected term, but got error:" ++++ s)
opTT2CommandArg _ a = AError ("expected term, but got:" ++++ prCommandArg a)