tb -trees ; rl ; path in gfe ; removed spurious "file not found"

9 files changed, 59 insertions, 24 deletions

diff --git a/src/GF/Compile/MkConcrete.hs b/src/GF/Compile/MkConcrete.hs
index c8b5e338e..a0af24007 100644
--- a/src/GF/Compile/MkConcrete.hs
+++ b/src/GF/Compile/MkConcrete.hs
@@ -55,12 +55,13 @@ mkConcretes files = do
   ress <- mapM getResPath files
   let grps = groupBy (\a b -> fst a == fst b) $ 
                sortBy (\a b -> compare (fst a) (fst b)) $ zip ress files
-  mapM_ mkCncGroups [(r,map snd gs) | gs@((r,_):_) <- grps]
+  mapM_ mkCncGroups [(rp,map snd gs) | gs@((rp,_):_) <- grps]
 
-mkCncGroups (res,files) = do
+mkCncGroups ((res,path),files) = do
   putStrLnFlush $ "Going to preprocess examples in " ++ unwords files
   putStrLn $ "Compiling resource " ++ res
-  egr <- appIOE $ shellStateFromFiles (options [beSilent]) emptyShellState res
+  let opts = options [beSilent,pathList path]
+  egr <- appIOE $ shellStateFromFiles opts emptyShellState res
   gr  <- err (\s -> putStrLn s >> error "resource grammar rejected") 
            (return . firstStateGrammar) egr
   let parser cat = 
@@ -81,12 +82,18 @@ mkConcrete parser morpho file = do
   appendFile out "\n"
   mapM_ (mkCnc out parser morpho) cont
 
-getResPath :: FilePath -> IO String
+getResPath :: FilePath -> IO (String,String)
 getResPath file = do
   s <- liftM lines $ readFileIf file
-  return $ case head (dropWhile (all isSpace) s) of
-    '-':'-':'#':path -> reverse (takeWhile (not . (=='=')) (reverse path))
-    _ -> error "first line must be --# -resource=<PATH>" 
+  case filter (not . all isSpace) s of
+    res:path:_ | is "resource" res && is "path" path -> return (val res, val path)
+    res:_ | is "resource" res -> return (val res, "")
+    _ -> error "expected --# -resource=FILE and optional --# -path=PATH"
+ where
+   val = dropWhile (isSpace) . tail . dropWhile (not . (=='='))
+   is tag s = case words s of
+     "--#":w:_ -> isPrefixOf ('-':tag) w
+     _ -> False 
 
 getExLines :: String -> [Either String String]
 getExLines = getl . lines where
diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs
index ab9beea36..33e20b03b 100644
--- a/src/GF/Compile/ShellState.hs
+++ b/src/GF/Compile/ShellState.hs
@@ -372,6 +372,10 @@ morphoOfLang st  = stateMorpho    . stateGrammarOfLang st
 probsOfLang st   = stateProbs     . stateGrammarOfLang st
 optionsOfLang st = stateOptions   . stateGrammarOfLang st
 
+removeLang :: Language -> ShellState -> ShellState
+removeLang lang st = purgeShellState $ st{concretes = concs1} where
+  concs1 = filter ((/=lang) . snd . fst) $ concretes st
+
 -- | the last introduced grammar, stored in options, is the default for operations
 firstStateGrammar :: ShellState -> StateGrammar
 firstStateGrammar st = errVal (stateAbstractGrammar st) $ do
diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs
index 81ddd44af..0d0e7ad35 100644
--- a/src/GF/Infra/Option.hs
+++ b/src/GF/Infra/Option.hs
@@ -256,7 +256,8 @@ showMulti    = iOpt "multi"
 fromSource   = iOpt "src"
 makeConcrete = iOpt "examples"
 fromExamples = iOpt "ex"
-openEditor = iOpt "edit"
+openEditor   = iOpt "edit"
+getTrees     = iOpt "trees"
 
 -- ** mainly for stand-alone
 
diff --git a/src/GF/Infra/UseIO.hs b/src/GF/Infra/UseIO.hs
index 7bf9edaf1..76563b5ad 100644
--- a/src/GF/Infra/UseIO.hs
+++ b/src/GF/Infra/UseIO.hs
@@ -88,8 +88,11 @@ isSep :: Char -> Bool
 isSep c = c == '/' || c == '\\'
 
 getFilePath :: [FilePath] -> String -> IO (Maybe FilePath)
-getFilePath paths file = get paths where
-  get []     = putStrLnFlush ("file" +++ file +++ "not found") >> return Nothing
+getFilePath ps file = getFilePathMsg ("file" +++ file +++ "not found\n") ps file
+
+getFilePathMsg :: String -> [FilePath] -> String -> IO (Maybe FilePath)
+getFilePathMsg msg paths file = get paths where
+  get []     = putStrFlush msg >> return Nothing
   get (p:ps) = let pfile = prefixPathName p file in
                catch (readFile pfile >> return (Just pfile)) (\_ -> get ps)
 
@@ -104,7 +107,7 @@ readFileIfPath paths file = do
 
 doesFileExistPath :: [FilePath] -> String -> IOE Bool
 doesFileExistPath paths file = do
-  mpfile <- ioeIO $ getFilePath paths file
+  mpfile <- ioeIO $ getFilePathMsg "" paths file
   return $ maybe False (const True) mpfile
 
 -- | first var is lib prefix, second is like class path
diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs
index 9eab757b7..0d5332fb8 100644
--- a/src/GF/Shell.hs
+++ b/src/GF/Shell.hs
@@ -193,8 +193,8 @@ execC co@(comm, opts0) sa@(sh@(st,(h,_,_,_)),a) = checkOptions st co >> case com
   CChangeMain ma -> changeStateErr (changeMain ma) sa
   CStripState    -> changeState purgeShellState sa
 
+  CRemoveLanguage lan -> changeState (removeLang lan) sa
 {-
-  CRemoveLanguage lan -> changeState (removeLanguage lan) sa
   CTransformGrammar file -> do
     s <- transformGrammarFile opts file
     returnArg (AString s) sa
@@ -293,6 +293,11 @@ execC co@(comm, opts0) sa@(sh@(st,(h,_,_,_)),a) = checkOptions st co >> case com
   CTreeBank | oElem doCompute opts -> do -- -c
     let bank = prCommandArg a
     returnArg (AString $ unlines $ testTreebank 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" ----
diff --git a/src/GF/Shell/HelpFile.hs b/src/GF/Shell/HelpFile.hs
index e61c5cc6a..2f21184f1 100644
--- a/src/GF/Shell/HelpFile.hs
+++ b/src/GF/Shell/HelpFile.hs
@@ -80,7 +80,7 @@ txtHelpFile =
   "\n      i English.gf                      -- ordinary import of Concrete" ++
   "\n      i -retain german/ParadigmsGer.gf  -- import of Resource to test" ++
   "\n      " ++
-  "\n* rl, remove_language: rl Language" ++
+  "\nrl, remove_language: rl Language" ++
   "\n      Takes away the language from the state." ++
   "\n" ++
   "\ne,  empty: e" ++
@@ -236,10 +236,12 @@ txtHelpFile =
   "\n      to an existing treebank." ++
   "\n  options:" ++
   "\n     -c        compare to existing xml-formatted treebank" ++
+  "\n     -trees    return the trees of the treebank" ++
   "\n     -xml      wrap the treebank (or comparison results) with XML tags" ++
   "\n  examples:" ++
   "\n     gr -cat=S -number=100 | tb -xml | wf tb.xml -- random treebank into file" ++
-  "\n     rf tb.txt | tb -c                           -- read comparison treebank from file" ++
+  "\n     rf tb.xml | tb -c                           -- compare-test treebank from file" ++
+  "\n     rf old.xml | tb -trees | tb -xml            -- create new treebank from old" ++
   "\n" ++
   "\ntt, test_tokenizer: tt String" ++
   "\n      Show the token list sent to the parser when String is parsed." ++
diff --git a/src/GF/Shell/ShellCommands.hs b/src/GF/Shell/ShellCommands.hs
index 56c172037..1351e8784 100644
--- a/src/GF/Shell/ShellCommands.hs
+++ b/src/GF/Shell/ShellCommands.hs
@@ -183,7 +183,7 @@ optionsOfCommand co = case co of
   CGenerateRandom -> both "cf prob" "cat lang number depth"
   CGenerateTrees -> both "metas" "atoms depth alts cat lang number"
   CPutTerm -> flags "transform number"
-  CTreeBank -> opts "c xml"
+  CTreeBank -> opts "c xml trees"
   CWrapTerm _ -> opts "c"
   CApplyTransfer _ -> flags "lang transfer"
   CMorphoAnalyse -> both "short" "lang"
diff --git a/src/GF/UseGrammar/Treebank.hs b/src/GF/UseGrammar/Treebank.hs
index 12dc598f2..8f5fd71a7 100644
--- a/src/GF/UseGrammar/Treebank.hs
+++ b/src/GF/UseGrammar/Treebank.hs
@@ -12,7 +12,7 @@
 -- Purpose: to generate treebanks.
 -----------------------------------------------------------------------------
 
-module GF.UseGrammar.Treebank (mkTreebank,testTreebank) where
+module GF.UseGrammar.Treebank (mkTreebank,testTreebank,treesTreebank) where
 
 import GF.Compile.ShellState 
 import GF.UseGrammar.Linear (linTree2string)
@@ -49,7 +49,9 @@ mkTreebank opts sh com trees = putInXML opts "treebank" comm (concatMap mkItem t
    tris    = zip trees [1..]
 
 testTreebank :: Options -> ShellState -> String -> Res
-testTreebank opts sh = putInXML opts "testtreebank" [] . concatMap testOne . getTreebank . lines
+testTreebank opts sh = putInXML opts "testtreebank" [] . 
+                       concatMap testOne . 
+                       getTreebanks . lines
  where
   testOne (e,lang,str0) = do
     let tr = annot gr e
@@ -61,6 +63,10 @@ testTreebank opts sh = putInXML opts "testtreebank" [] . concatMap testOne . get
       ]
   gr = firstStateGrammar sh
 
+treesTreebank :: Options -> String -> [String]
+treesTreebank _ = terms . getTreebank . lines where
+  terms ts = [t | (t,_) <- ts]
+
 -- string vs. IO
 type Res = [String] -- IO ()
 puts :: String -> Res
@@ -68,18 +74,23 @@ puts = return  -- putStrLn
 ret = [] -- return ()
 --
 
-getTreebank :: [String] -> [(String,String,String)]
+getTreebanks :: [String] -> [(String,String,String)]
+getTreebanks = concatMap grps . getTreebank where
+  grps (t,lls) = [(t,x,y) | (x,y) <- lls]
+
+getTreebank :: [String] -> [(String,[(String,String)])]
 getTreebank ll = case ll of
-  [] -> []
-  l:ls -> 
+  l:ls@(_:_:_) -> 
     let (l1,l2)   = getItem ls
         (tr,lins) = getTree l1
         lglins    = getLins lins
-    in [(tr,lang,str) | (lang,str) <- lglins] ++ getTreebank l2
+    in (tr,lglins) : getTreebank l2
+  _ -> []
  where
    getItem = span ((/="</item") . take 6)
 
-   getTree (_:ss) = let (t1,t2) = span ((/="</tree") . take 6) ss in (last t1, drop 1 t2)
+   getTree (_:ss) = 
+     let (t1,t2) = span ((/="</tree") . take 6) ss in (last t1, drop 1 t2)
 
    getLins (beg:str:end:ss) = (getLang beg, str):getLins ss
    getLins _ = []
diff --git a/src/HelpFile b/src/HelpFile
index a44470f0b..4c3973d02 100644
--- a/src/HelpFile
+++ b/src/HelpFile
@@ -51,7 +51,7 @@ i,  import: i File
       i English.gf                      -- ordinary import of Concrete
       i -retain german/ParadigmsGer.gf  -- import of Resource to test
       
-* rl, remove_language: rl Language
+rl, remove_language: rl Language
       Takes away the language from the state.
 
 e,  empty: e
@@ -207,10 +207,12 @@ tb, tree_bank: tb
       to an existing treebank.
   options:
      -c        compare to existing xml-formatted treebank
+     -trees    return the trees of the treebank
      -xml      wrap the treebank (or comparison results) with XML tags
   examples:
      gr -cat=S -number=100 | tb -xml | wf tb.xml -- random treebank into file
-     rf tb.txt | tb -c                           -- read comparison treebank from file
+     rf tb.xml | tb -c                           -- compare-test treebank from file
+     rf old.xml | tb -trees | tb -xml            -- create new treebank from old
 
 tt, test_tokenizer: tt String
       Show the token list sent to the parser when String is parsed.