example substitutions

6 files changed, 56 insertions, 28 deletions

diff --git a/doc/gf-history.html b/doc/gf-history.html
index 1e5555c11..c6de42c03 100644
--- a/doc/gf-history.html
+++ b/doc/gf-history.html
@@ -18,7 +18,7 @@ Changes in functionality since May 17, 2005, release of GF Version 2.2
 <b>grammar writing by examples</b>. Files of this format are first
 converted to <tt>.gf</tt> files by the command
 <pre>
-  gf -makeconcrete File.gfe
+  gf -examples File.gfe
 </pre>
 See <a href="../lib/resource/doc/examples/QuestionsI.gfe">
 <tt>../lib/resource/doc/examples/QuestionsI.gfe</tt></a>
diff --git a/src/GF.hs b/src/GF.hs
index 2b7b6880d..96cf33661 100644
--- a/src/GF.hs
+++ b/src/GF.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stability)
 -- Portability : (portability)
 --
--- > CVS $Date: 2005/06/02 17:31:56 $ 
+-- > CVS $Date: 2005/06/03 21:51:58 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.26 $
+-- > CVS $Revision: 1.27 $
 --
 -- The Main module of GF program.
 -----------------------------------------------------------------------------
@@ -60,7 +60,7 @@ main = do
         _ -> putStrLnFlush "expecting exactly one gf file to compile"
 
     _ | opt makeConcrete -> do
-        mapM_ mkConcrete fs
+        mkConcretes fs
 
     _ | opt doBatch -> do
       if opt beSilent then return () else putStrLnFlush "<gfbatch>"
@@ -85,7 +85,7 @@ helpMsg = unlines [
   "     -noemit      do not emit code when compiling",
   "     -v           be verbose when compiling",
   "  -batch        structure session by XML tags (use > to send into a file)",
-  "  -makeconcrete batch-compile .gfe file to concrete syntax using parser",
+  "  -examples     batch-compile .gfe file by parsing examples",
   "  -help         show this message",
   "To use the GUI: jgf <option>* <file>*"
   ]
diff --git a/src/GF/Compile/MkConcrete.hs b/src/GF/Compile/MkConcrete.hs
index 75b4f215e..061d76cc5 100644
--- a/src/GF/Compile/MkConcrete.hs
+++ b/src/GF/Compile/MkConcrete.hs
@@ -12,11 +12,14 @@
 -- Compile a gfl file into a concrete syntax by using the parser on a resource grammar.
 -----------------------------------------------------------------------------
 
-module GF.Compile.MkConcrete (mkConcrete) where
+module GF.Compile.MkConcrete (mkConcretes,mkCncLine) where
 
 import GF.Grammar.Values (Tree,tree2exp)
 import GF.Grammar.PrGrammar (prt_)
-import GF.Compile.ShellState (absId,firstStateGrammar)
+import GF.Grammar.Grammar (Term(Q,QC)) ---
+import GF.Grammar.Macros (composSafeOp, record2subst)
+import GF.Compile.ShellState (firstStateGrammar)
+import GF.Compile.PGrammar (pTerm)
 import GF.API
 import qualified GF.Embed.EmbedAPI as EA
 
@@ -35,22 +38,32 @@ import Control.Monad
 -- Format of resource path (on first line):
 --    --# -resource=PATH
 -- Other lines are copied verbatim.
--- Assumes: resource has been built with 
+-- The resource has to be built with 
 --    i -src -optimize=share SOURCE
 -- because mcfg parsing is used.
+-- A sequence of files can be processed with the same resource without
+-- rebuilding the grammar and parser.
 
-
-mkConcrete :: FilePath -> IO ()
-mkConcrete file = do
+mkConcretes :: [FilePath] -> IO ()
+mkConcretes [] = putStrLn "no files to process"
+mkConcretes files@(file:_) = do
   cont <- liftM lines $ readFileIf file
   let res = getResPath cont
   egr <- appIOE $ 
-    optFile2grammar (options [useOptimizer "share",fromSource,beSilent,notEmitCode]) res --- for -mcfg
+    optFile2grammar (options 
+      [useOptimizer "share",fromSource,beSilent,notEmitCode]) res --- for -mcfg
   gr  <- err (\s -> putStrLn s >> error "resource file rejected") return egr
-  let abs = prt_ $ absId gr
   let parser cat = errVal ([],"No parse") . 
                    optParseArgErrMsg (options [newMParser, firstCat cat, beVerbose]) gr
   let morpho = isKnownWord gr
+  mapM_ (mkConcrete parser morpho) files
+
+type Parser = String -> String -> ([Tree],String)
+type Morpho = String -> Bool 
+
+mkConcrete :: Parser -> Morpho -> FilePath -> IO ()
+mkConcrete parser morpho file = do
+  cont <- liftM lines $ readFileIf file
   let out = suffixFile "gf" $ justModuleName file
   writeFile out ""
   mapM_ (mkCnc out parser morpho) cont
@@ -60,8 +73,7 @@ getResPath s = case head (dropWhile (all isSpace) s) of
   '-':'-':'#':path -> reverse (takeWhile (not . (=='=')) (reverse path))
   _ -> error "first line must be --# -resource=<PATH>" 
 
-mkCnc :: FilePath -> (String -> String -> ([Tree],String)) -> (String -> Bool) -> 
-         String -> IO ()
+mkCnc :: FilePath -> Parser -> Morpho -> String -> IO ()
 mkCnc out parser morpho line = do
   let (res,msg) = mkCncLine parser morpho line
   appendFile out res
@@ -77,15 +89,15 @@ mkCncLine parser morpho line = case words line of
  where
    mkLinRule key s = 
     let
-       (pre,str)  = span (/= "in") s
+       (pre,str)    = span (/= "in") s
        ([cat],rest) = splitAt 1 $ tail str
-       lin        = init (tail (unwords (init rest))) -- unquote
+       (lin,subst)  = span (/= '"') $ tail $ unwords rest
        def
         | last pre /= "=" = line  -- ordinary lin rule
         | otherwise  = case parser cat lin of 
-           ([t],_)  -> ind ++ key +++ unwords pre +++ prt_ (tree2exp t) +++ ";" 
-           (t:_,_)  -> ind ++ key +++ unwords pre +++ prt_ (tree2exp t) +++ ";" 
-                        +++ "-- AMBIGUOUS"
+           (t:ts,_) -> ind ++ key +++ unwords pre +++ 
+                       doSubst (init (tail subst)) (tree2exp t) +++ ";" ++
+                       if null ts then [] else " -- AMBIGUOUS"
            ([],msg) -> "{-" ++ line ++++ morph lin ++++ "-}" 
     in
      (def,def)
@@ -93,3 +105,13 @@ mkCncLine parser morpho line = case words line of
      [] -> ""
      ws -> "unknown words: " ++ unwords ws
    ind = takeWhile isSpace line
+
+doSubst :: String -> Term -> String
+doSubst subst0 trm = prt_ $ subt subst trm where
+  subst 
+    | all isSpace subst0 = []
+    | otherwise = err error id $ pTerm subst0 >>= record2subst
+  subt g t = case t of
+    Q  _ c -> maybe t id $ lookup c g
+    QC _ c -> maybe t id $ lookup c g
+    _      -> composSafeOp (subt g) t
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
index 89866c6bd..746526c85 100644
--- a/src/GF/Grammar/Macros.hs
+++ b/src/GF/Grammar/Macros.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/09 15:45:00 $ 
+-- > CVS $Date: 2005/06/03 21:51:58 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.21 $
+-- > CVS $Revision: 1.22 $
 --
 -- Macros for constructing and analysing source code terms.
 --
@@ -280,6 +280,11 @@ mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs]
 mkRecType :: (Int -> Label) -> [Type] -> Type
 mkRecType = mkRecTypeN 0
 
+record2subst :: Term -> Err Substitution
+record2subst t = case t of
+  R fs -> return [(zIdent x, t) | (LIdent x,(_,t)) <- fs]
+  _ -> prtBad "record expected, found" t
+
 typeType, typePType, typeStr, typeTok, typeStrs :: Term
 
 typeType  = srt "Type"
diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs
index d84c7ca7e..4962a9f20 100644
--- a/src/GF/Infra/Option.hs
+++ b/src/GF/Infra/Option.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/06/02 10:23:52 $ 
+-- > CVS $Date: 2005/06/03 21:51:59 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.28 $
+-- > CVS $Revision: 1.29 $
 --
 -- Options and flags used in GF shell commands and files.
 --
@@ -244,7 +244,7 @@ nostripQualif = iOpt "nostrip"
 showAll      = iOpt "all"
 showMulti    = iOpt "multi"
 fromSource   = iOpt "src"
-makeConcrete = iOpt "makeconcrete"
+makeConcrete = iOpt "examples"
 
 -- ** mainly for stand-alone
 
diff --git a/src/GF/UseGrammar/GetTree.hs b/src/GF/UseGrammar/GetTree.hs
index a8d5fcab2..e71475654 100644
--- a/src/GF/UseGrammar/GetTree.hs
+++ b/src/GF/UseGrammar/GetTree.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:23:47 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.7 $
+-- > CVS $Date: 2005/06/03 21:51:59 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.8 $
 --
 -- how to form linearizable trees from strings and from terms of different levels
 --
@@ -39,6 +39,7 @@ string2tree :: StateGrammar -> String -> Tree
 string2tree gr = errVal uTree . string2treeErr gr
 
 string2treeErr :: StateGrammar -> String -> Err Tree
+string2treeErr _ "" = Bad "empty string"
 string2treeErr gr s = do
   t <- pTerm s
   let t1 = refreshMetas [] t