summaryrefslogtreecommitdiff
path: root/src/GF
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF')
-rw-r--r--src/GF/Compile/MkConcrete.hs21
-rw-r--r--src/GF/Compile/ShellState.hs4
-rw-r--r--src/GF/Infra/Option.hs3
-rw-r--r--src/GF/Infra/UseIO.hs9
-rw-r--r--src/GF/Shell.hs7
-rw-r--r--src/GF/Shell/HelpFile.hs6
-rw-r--r--src/GF/Shell/ShellCommands.hs2
-rw-r--r--src/GF/UseGrammar/Treebank.hs25
8 files changed, 55 insertions, 22 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 _ = []
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 15:04:55 +0000