From f0e13dd29f495a109e0fa693624c9455bb36b2b1 Mon Sep 17 00:00:00 2001
From: aarne <unknown>
Date: Thu, 2 Jun 2005 16:31:56 +0000
Subject: [PATCH] better MkConcrete and example in lib/resource/doc/example

---
 src/GF.hs                    |  6 +++---
 src/GF/API.hs                | 20 +++++++++++++------
 src/GF/Compile/MkConcrete.hs | 38 +++++++++++++++++++++++-------------
 3 files changed, 41 insertions(+), 23 deletions(-)

diff --git a/src/GF.hs b/src/GF.hs
index 5cd474f1f..2b7b6880d 100644
--- a/src/GF.hs
+++ b/src/GF.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stability)
 -- Portability : (portability)
 --
--- > CVS $Date: 2005/06/02 10:23:52 $ 
+-- > CVS $Date: 2005/06/02 17:31:56 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.25 $
+-- > CVS $Revision: 1.26 $
 --
 -- The Main module of GF program.
 -----------------------------------------------------------------------------
@@ -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 .gfp file to concrete syntax using parser",
+  "  -makeconcrete batch-compile .gfe file to concrete syntax using parser",
   "  -help         show this message",
   "To use the GUI: jgf <option>* <file>*"
   ]
diff --git a/src/GF/API.hs b/src/GF/API.hs
index 20f32b59e..d9c9afe49 100644
--- a/src/GF/API.hs
+++ b/src/GF/API.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/17 11:20:25 $ 
--- > CVS $Author: peb $
--- > CVS $Revision: 1.36 $
+-- > CVS $Date: 2005/06/02 17:31:57 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.37 $
 --
 -- Application Programmer's Interface to GF; also used by Shell. AR 10/11/2001
 -----------------------------------------------------------------------------
@@ -55,6 +55,7 @@ import qualified GF.Infra.Ident as I
 import qualified GF.Compile.GrammarToCanon as GC
 import qualified GF.Canon.CanonToGrammar as CG
 import qualified GF.Canon.MkGFC as MC
+import qualified GF.Embed.EmbedAPI as EA
 
 import GF.UseGrammar.Editing
 
@@ -145,9 +146,11 @@ string2GFCat = string2CFCat
 -- then stg for customizable and internal use
 
 optFile2grammar :: Options -> FilePath -> IOE GFGrammar
-optFile2grammar os f = do
-  ((_,_,gr),_) <- compileModule os emptyShellState f
-  ioeErr $ grammar2stateGrammar os gr
+optFile2grammar os f  
+  | fileSuffix f == "gfcm" = ioeIO $ liftM firstStateGrammar $ EA.file2grammar f
+  | otherwise = do
+      ((_,_,gr),_) <- compileModule os emptyShellState f
+      ioeErr $ grammar2stateGrammar os gr
 
 optFile2grammarE :: Options -> FilePath -> IOE GFGrammar
 optFile2grammarE = optFile2grammar
@@ -292,6 +295,11 @@ morphoAnalyse opts gr
  where
   mo = morpho gr
 
+isKnownWord :: GFGrammar -> String -> Bool
+isKnownWord gr s = case morphoAnalyse (options [beShort]) gr s of
+  a@(_:_:_) -> last (init a) /= '*'  -- [word *]
+  _ -> False
+
 {-
 prExpXML :: StateGrammar -> Term -> [String]
 prExpXML gr = prElementX . term2elemx (stateAbstract gr) 
diff --git a/src/GF/Compile/MkConcrete.hs b/src/GF/Compile/MkConcrete.hs
index 6295e9851..be3d6f5b4 100644
--- a/src/GF/Compile/MkConcrete.hs
+++ b/src/GF/Compile/MkConcrete.hs
@@ -16,11 +16,13 @@ module GF.Compile.MkConcrete (mkConcrete) where
 
 import GF.Grammar.Values (Tree,tree2exp)
 import GF.Grammar.PrGrammar (prt_)
-import GF.Compile.ShellState (absId,stateGrammarWords)
+import GF.Compile.ShellState (absId,firstStateGrammar)
 import GF.API
+import qualified GF.Embed.EmbedAPI as EA
 
 import GF.Data.Operations
 import GF.Infra.UseIO
+import GF.Infra.Option
 
 import Data.Char
 import Control.Monad
@@ -33,26 +35,31 @@ import Control.Monad
 -- Format of resource path (on first line):
 --    --# -resource=PATH
 -- Other lines are copied verbatim.
+-- Assumes: resource has been built with 
+--    i -src -optimize=share SOURCE
+-- because mcfg parsing is used.
 
 
 mkConcrete :: FilePath -> IO ()
 mkConcrete file = do
   cont <- liftM lines $ readFileIf file
   let res = getResPath cont
-  gr   <- file2grammar res
+  egr <- appIOE $ optFile2grammar (options [useOptimizer "share"]) res --- for -mcfg
+  gr  <- err (\s -> putStrLn s >> error "resource file rejected") return egr
   let abs = prt_ $ absId gr
-  let parser cat = parse gr (string2GFCat abs cat)
-  let mor = \w -> isInBinTree w $ sorted2tree [(w,()) | w <- stateGrammarWords gr]
+  let parser cat = errVal ([],"No parse") . 
+                   optParseArgErrMsg (options [newMParser, firstCat cat, beVerbose]) gr
+  let morpho = isKnownWord gr
   writeFile (suffixFile "gf" (justModuleName file)) $ unlines $ 
-    map (mkCnc parser mor) cont
+    map (mkCnc parser morpho) cont
 
 getResPath :: [String] -> String
 getResPath s = case head (dropWhile (all isSpace) s) of
   '-':'-':'#':path -> reverse (takeWhile (not . (=='=')) (reverse path))
   _ -> error "first line must be --# -resource=<PATH>" 
 
-mkCnc :: (String -> String -> [Tree]) -> (String -> Bool) -> String -> String
-mkCnc parser morph line = case words line of
+mkCnc :: (String -> String -> ([Tree],String)) -> (String -> Bool) -> String -> String
+mkCnc parser morpho line = case words line of
   "lin" : rest -> mkLinRule rest
   _ -> line
  where
@@ -61,11 +68,14 @@ mkCnc parser morph line = case words line of
        (pre,str)  = span (/= "in") s
        ([cat],rest) = splitAt 1 $ tail str
        lin        = init (tail (unwords (init rest))) -- unquote
-       def = case parser cat lin of 
-         [t] -> prt_ $ tree2exp t 
-         t:_ -> prt_ (tree2exp t) +++ "{- AMBIGUOUS -}"
-         []  -> ""
+       def 
+        | last pre /= "=" = line  -- ordinary lin rule
+        | otherwise  = case parser cat lin of 
+           ([t],_)  -> "lin " ++ unwords pre +++ prt_ (tree2exp t) +++ ";" 
+           (t:_,_)  -> "lin " ++ unwords pre +++ prt_ (tree2exp t) +++ "{- AMBIGUOUS -} ;"
+           ([],msg) -> "{-" ++ line ++++ morph lin ++++ "-}" 
     in
-     if null def
-       then "-- NO PARSE " ++ line
-       else "lin " ++ unwords pre +++ def +++ ";"
+     def
+   morph s = case [w | w <- words s, not (morpho w)] of
+     [] -> ""
+     ws -> "unknown words: " ++ unwords ws