lin rules by parsing

src/GF.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stability)
 -- Portability : (portability)
 --
--- > CVS $Date: 2005/05/12 10:03:33 $ 
+-- > CVS $Date: 2005/06/02 10:23:52 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.24 $
+-- > CVS $Revision: 1.25 $
 --
 -- The Main module of GF program.
 -----------------------------------------------------------------------------
@@ -20,6 +20,7 @@ import GF.Infra.UseIO
 import GF.Infra.Option
 import GF.API.IOGrammar
 import GF.Compile.ShellState
+import GF.Compile.MkConcrete
 import GF.Shell
 import GF.Shell.SubShell
 import GF.Shell.ShellCommands
@@ -58,6 +59,9 @@ main = do
         [f] -> batchCompile os f
         _ -> putStrLnFlush "expecting exactly one gf file to compile"
 
+    _ | opt makeConcrete -> do
+        mapM_ mkConcrete fs
+
     _ | opt doBatch -> do
       if opt beSilent then return () else putStrLnFlush "<gfbatch>"
       st <- useIOE st0 $ 
@@ -77,11 +81,12 @@ main = do
 helpMsg = unlines [
   "Usage: gf <option>* <file>*",
   "Options:",
-  "  -make    batch-compile files",
+  "  -make         batch-compile files",
-  "   -noemit do not emit code when compiling",
+  "     -noemit      do not emit code when compiling",
-  "   -v      be verbose when compiling",
+  "     -v           be verbose when compiling",
-  "  -batch   structure session by XML tags (use > to send into a file)",
+  "  -batch        structure session by XML tags (use > to send into a file)",
-  "  -help    show this message",
+  "  -makeconcrete batch-compile .gfp file to concrete syntax using parser",
+  "  -help         show this message",
   "To use the GUI: jgf <option>* <file>*"
   ]
 

src/GF/Compile/MkConcrete.hs

@@ -0,0 +1,71 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : MkConcrete
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 
+-- > CVS $Author: 
+-- > CVS $Revision: 
+--
+-- Compile a gfl file into a concrete syntax by using the parser on a resource grammar.
+-----------------------------------------------------------------------------
+
+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.API
+
+import GF.Data.Operations
+import GF.Infra.UseIO
+
+import Data.Char
+import Control.Monad
+
+-- translate strings into lin rules by parsing in a resource
+-- grammar. AR 2/6/2005
+
+-- Format of rule (on one line):
+--    lin F x y = in C "ssss" ;
+-- Format of resource path (on first line):
+--    --# -resource=PATH
+-- Other lines are copied verbatim.
+
+
+mkConcrete :: FilePath -> IO ()
+mkConcrete file = do
+  cont <- liftM lines $ readFileIf file
+  let res = getResPath cont
+  gr   <- file2grammar res
+  let abs = prt_ $ absId gr
+  let parser cat = parse gr (string2GFCat abs cat)
+  let mor = \w -> isInBinTree w $ sorted2tree [(w,()) | w <- stateGrammarWords gr]
+  writeFile (suffixFile "gf" (justModuleName file)) $ unlines $ 
+    map (mkCnc parser mor) 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
+  "lin" : rest -> mkLinRule rest
+  _ -> line
+ where
+   mkLinRule s = 
+    let
+       (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 -}"
+         []  -> ""
+    in
+     if null def
+       then "-- NO PARSE " ++ line
+       else "lin " ++ unwords pre +++ def +++ ";"

src/GF/Infra/Option.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/11 10:28:16 $ 
+-- > CVS $Date: 2005/06/02 10:23:52 $ 
--- > CVS $Author: peb $
+-- > CVS $Author: aarne $
--- > CVS $Revision: 1.27 $
+-- > CVS $Revision: 1.28 $
 --
 -- Options and flags used in GF shell commands and files.
 --
@@ -244,6 +244,7 @@ nostripQualif = iOpt "nostrip"
 showAll      = iOpt "all"
 showMulti    = iOpt "multi"
 fromSource   = iOpt "src"
+makeConcrete = iOpt "makeconcrete"
 
 -- ** mainly for stand-alone
 

src/GF/UseGrammar/Parsing.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/31 12:47:52 $ 
+-- > CVS $Date: 2005/06/02 10:23:52 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.24 $
+-- > CVS $Revision: 1.25 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
@@ -127,7 +127,7 @@ trees2trms opts sg cn as ts0 info = do
            else return ps
 
   if verb 
-     then checkWarn $ " the token list" +++ show as ++++ unknown as +++++ info
+     then checkWarn $ " the token list" +++ show as ++++ unknownWords sg as +++++ info
      else return ()
 
   return $ optIntOrAll opts flagNumber $ nub ts
@@ -138,9 +138,10 @@ trees2trms opts sg cn as ts0 info = do
    verb    = oElem beVerbose opts
    forgive = oElem forgiveParse opts
 
-   unknown ts = case filter noMatch [t | t@(TS _) <- ts] of
+unknownWords sg ts = case filter noMatch [t | t@(TS _) <- ts] of
      [] -> "where all words are known"
      us -> "with the unknown tokens" +++ show us --- needs to be fixed for literals
+  where
    terminals = map TS $ stateGrammarWords sg
    noMatch t = all (not . compatTok t) terminals