lin rules by parsing

3 files changed, 80 insertions, 7 deletions

diff --git a/src/GF/Compile/MkConcrete.hs b/src/GF/Compile/MkConcrete.hs
new file mode 100644
index 000000000..6295e9851
--- /dev/null
+++ b/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 +++ ";"
diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs
index 779fa96f0..d84c7ca7e 100644
--- a/src/GF/Infra/Option.hs
+++ b/src/GF/Infra/Option.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/11 10:28:16 $ 
--- > CVS $Author: peb $
--- > CVS $Revision: 1.27 $
+-- > CVS $Date: 2005/06/02 10:23:52 $ 
+-- > CVS $Author: aarne $
+-- > 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
 
diff --git a/src/GF/UseGrammar/Parsing.hs b/src/GF/UseGrammar/Parsing.hs
index 7620bb4ab..a9da37df5 100644
--- a/src/GF/UseGrammar/Parsing.hs
+++ b/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