diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/GF.hs | 19 | ||||
| -rw-r--r-- | src/GF/Compile/MkConcrete.hs | 71 | ||||
| -rw-r--r-- | src/GF/Infra/Option.hs | 7 | ||||
| -rw-r--r-- | src/GF/UseGrammar/Parsing.hs | 9 |
4 files changed, 92 insertions, 14 deletions
@@ -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", - " -noemit do not emit code when compiling", - " -v be verbose when compiling", - " -batch structure session by XML tags (use > to send into a file)", - " -help show this message", + " -make batch-compile files", + " -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", + " -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 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 |