summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/GF/Speech/PrGSL.hs36
-rw-r--r--src/GF/UseGrammar/Custom.hs4
2 files changed, 27 insertions, 13 deletions
diff --git a/src/GF/Speech/PrGSL.hs b/src/GF/Speech/PrGSL.hs
index 58271ec2c..4598885ff 100644
--- a/src/GF/Speech/PrGSL.hs
+++ b/src/GF/Speech/PrGSL.hs
@@ -28,7 +28,7 @@
-- FIXME: figure out name prefix from grammar name
-module PrGSL (prGSL) where
+module PrGSL (gslPrinter) where
import Ident
import CFGrammar
@@ -36,26 +36,36 @@ import Parser (Symbol(..))
import GrammarTypes
import PrintParser
import TransformCFG
+import Option
import Data.List
+import Data.Maybe (fromMaybe)
import Data.FiniteMap
-type GSLGrammar = [GSLRule]
+data GSLGrammar = GSLGrammar String [GSLRule]
data GSLRule = GSLRule String [GSLAlt]
type GSLAlt = [Symbol String Token]
type CatNames = FiniteMap String String
-prGSL :: CFGrammar -> String
-prGSL cfg = prGSLGrammar names gsl ""
+gslPrinter :: Options -> CFGrammar -> String
+gslPrinter opts = prGSL start
+ where mstart = getOptVal opts gStartCat
+ start = fromMaybe "S" mstart ++ "{}.s"
+
+prGSL :: String -- ^ startcat
+ -> CFGrammar -> String
+prGSL start cfg = prGSLGrammar names gsl ""
where
cfg' = makeNice cfg
- gsl = cfgToGSL cfg'
+ gsl = cfgToGSL start cfg'
names = mkCatNames "GSL_" gsl
-cfgToGSL :: [CFRule_] -> GSLGrammar
-cfgToGSL = map cfgRulesToGSLRule . sortAndGroupBy ruleCat
+cfgToGSL :: String -- ^ startcat
+ -> [CFRule_] -> GSLGrammar
+cfgToGSL start =
+ GSLGrammar start . map cfgRulesToGSLRule . sortAndGroupBy ruleCat
where
ruleCat (Rule c _ _) = c
ruleRhs (Rule _ r _) = r
@@ -63,14 +73,18 @@ cfgToGSL = map cfgRulesToGSLRule . sortAndGroupBy ruleCat
mkCatNames :: String -- name prefix
-> GSLGrammar -> CatNames
-mkCatNames pref gsl = listToFM (zip lhsCats names)
+mkCatNames pref (GSLGrammar start rules) =
+ listToFM (zipWith dotIfStart lhsCats names)
where names = [pref ++ show x | x <- [0..]]
- lhsCats = [ c | GSLRule c _ <- gsl ]
+ lhsCats = [ c | GSLRule c _ <- rules]
+ dotIfStart c n | c == start = (c, "." ++ n)
+ | otherwise = (c, n)
prGSLGrammar :: CatNames -> GSLGrammar -> ShowS
-prGSLGrammar names g = header . unlinesS (map prGSLrule g)
+prGSLGrammar names (GSLGrammar start g) = header . unlinesS (map prGSLrule g)
where
- header = showString ";GSL2.0" . nl
+ header = showString ";GSL2.0" . nl
+ . showString ("; startcat = " ++ start ) . nl
prGSLrule (GSLRule cat rhs) =
showString "; " . prtS cat . nl
. prGSLCat cat . sp . wrap "[" (unwordsS (map prGSLAlt rhs)) "]" . nl
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index 4fd12f12a..856f31b01 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -27,7 +27,7 @@ import PrGrammar
import PrOld
import MkGFC
import CFtoSRG
-import PrGSL (prGSL)
+import PrGSL (gslPrinter)
import Zipper
@@ -191,7 +191,7 @@ customGrammarPrinter =
,(strCI "cf", prCF . stateCF)
,(strCI "old", printGrammarOld . stateGrammarST)
,(strCI "srg", prSRG . stateCF)
- ,(strCI "gsl", prGSL . Cnv.cfg . statePInfo)
+ ,(strCI "gsl", \s -> gslPrinter (stateOptions s) $ Cnv.cfg $ statePInfo s)
,(strCI "lbnf", prLBNF . stateCF)
,(strCI "haskell", grammar2haskell . stateGrammarST)
,(strCI "morpho", prMorpho . stateMorpho)