summaryrefslogtreecommitdiff
path: root/src/GF
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF')
-rw-r--r--src/GF/Speech/PrGSL.hs126
-rw-r--r--src/GF/Speech/TransformCFG.hs102
-rw-r--r--src/GF/UseGrammar/Custom.hs2
3 files changed, 230 insertions, 0 deletions
diff --git a/src/GF/Speech/PrGSL.hs b/src/GF/Speech/PrGSL.hs
new file mode 100644
index 000000000..58271ec2c
--- /dev/null
+++ b/src/GF/Speech/PrGSL.hs
@@ -0,0 +1,126 @@
+{-
+ **************************************************************
+ GF Module
+
+ Description : This module prints a CFG as a Nuance GSL 2.0
+ grammar.
+
+ Author : Björn Bringert (bringert@cs.chalmers.se)
+
+ License : GPL (GNU General Public License)
+
+ Created : September 13, 2004
+
+ Modified :
+ **************************************************************
+-}
+
+-- FIXME: this modules should not be in cfgm, but where?
+
+-- FIXME: remove left-recursion
+
+-- FIXME: remove empty rules
+
+-- FIXME: remove categories with no RHS
+
+-- FIXME: remove / warn / fail if there are int / string literal
+-- categories in the grammar
+
+-- FIXME: figure out name prefix from grammar name
+
+module PrGSL (prGSL) where
+
+import Ident
+import CFGrammar
+import Parser (Symbol(..))
+import GrammarTypes
+import PrintParser
+import TransformCFG
+
+import Data.List
+import Data.FiniteMap
+
+
+type GSLGrammar = [GSLRule]
+data GSLRule = GSLRule String [GSLAlt]
+type GSLAlt = [Symbol String Token]
+
+type CatNames = FiniteMap String String
+
+prGSL :: CFGrammar -> String
+prGSL cfg = prGSLGrammar names gsl ""
+ where
+ cfg' = makeNice cfg
+ gsl = cfgToGSL cfg'
+ names = mkCatNames "GSL_" gsl
+
+cfgToGSL :: [CFRule_] -> GSLGrammar
+cfgToGSL = map cfgRulesToGSLRule . sortAndGroupBy ruleCat
+ where
+ ruleCat (Rule c _ _) = c
+ ruleRhs (Rule _ r _) = r
+ cfgRulesToGSLRule rs@(r:_) = GSLRule (ruleCat r) (map ruleRhs rs)
+
+mkCatNames :: String -- name prefix
+ -> GSLGrammar -> CatNames
+mkCatNames pref gsl = listToFM (zip lhsCats names)
+ where names = [pref ++ show x | x <- [0..]]
+ lhsCats = [ c | GSLRule c _ <- gsl ]
+
+prGSLGrammar :: CatNames -> GSLGrammar -> ShowS
+prGSLGrammar names g = header . unlinesS (map prGSLrule g)
+ where
+ header = showString ";GSL2.0" . nl
+ prGSLrule (GSLRule cat rhs) =
+ showString "; " . prtS cat . nl
+ . prGSLCat cat . sp . wrap "[" (unwordsS (map prGSLAlt rhs)) "]" . nl
+ prGSLAlt rhs = wrap "(" (unwordsS (map prGSLSymbol rhs')) ")"
+ where rhs' = rmPunct rhs
+ prGSLSymbol (Cat c) = prGSLCat c
+ prGSLSymbol (Tok t) = wrap "\"" (prtS t) "\""
+ prGSLCat c = showString n
+ where n = case lookupFM names c of
+ Nothing -> error $ "Unknown category: " ++ c
+ Just x -> x
+
+rmPunct :: [Symbol String Token] -> [Symbol String Token]
+rmPunct [] = []
+rmPunct (Tok t:ss) | all isPunct (prt t) = rmPunct ss
+rmPunct (s:ss) = s : rmPunct ss
+
+isPunct :: Char -> Bool
+isPunct c = c `elem` "-_.;.,?!"
+
+--
+-- * Utils
+--
+
+nl :: ShowS
+nl = showChar '\n'
+
+sp :: ShowS
+sp = showChar ' '
+
+wrap :: String -> ShowS -> String -> ShowS
+wrap o s c = showString o . s . showString c
+
+concatS :: [ShowS] -> ShowS
+concatS = foldr (.) id
+
+unwordsS :: [ShowS] -> ShowS
+unwordsS = concatS . intersperse sp
+
+unlinesS :: [ShowS] -> ShowS
+unlinesS = concatS . intersperse nl
+
+sortAndGroupBy :: Ord b =>
+ (a -> b) -- ^ Gets the value to sort and group by
+ -> [a]
+ -> [[a]]
+sortAndGroupBy f = groupBy (both (==) f) . sortBy (both compare f)
+
+both :: (b -> b -> c) -> (a -> b) -> a -> a -> c
+both f g x y = f (g x) (g y)
+
+prtS :: Print a => a -> ShowS
+prtS = showString . prt \ No newline at end of file
diff --git a/src/GF/Speech/TransformCFG.hs b/src/GF/Speech/TransformCFG.hs
new file mode 100644
index 000000000..322888da5
--- /dev/null
+++ b/src/GF/Speech/TransformCFG.hs
@@ -0,0 +1,102 @@
+{-
+ **************************************************************
+ GF Module
+
+ Description : This module does some useful transformations
+ on CFGs.
+
+ Author : Björn Bringert (bringert@cs.chalmers.se)
+
+ License : GPL (GNU General Public License)
+
+ Created : September 13, 2004
+
+ Modified :
+ **************************************************************
+-}
+
+module TransformCFG where
+
+import Ident
+import CFGrammar
+import Parser (Symbol(..))
+import GrammarTypes
+import PrintParser
+
+import Data.FiniteMap
+import Data.List
+import Data.Maybe (fromJust)
+
+import Debug.Trace
+
+-- FIXME: remove cycles
+
+
+-- not very nice to get replace the structured CFCat type with a simple string
+type CFRule_ = Rule CFName String Token
+
+type CFRules = FiniteMap String [CFRule_]
+
+makeNice :: CFGrammar -> [CFRule_]
+makeNice = concat . eltsFM . makeNice' . groupProds . cfgToCFRules
+ where makeNice' = removeLeftRecursion . removeEmptyCats
+
+cfgToCFRules :: CFGrammar -> [CFRule_]
+cfgToCFRules cfg = [Rule (catToString c) (map symb r) n | Rule c r n <- cfg]
+ where symb (Cat c) = Cat (catToString c)
+ symb (Tok t) = Tok t
+ catToString = prt
+
+-- | Group productions by their lhs categories
+groupProds :: [CFRule_] -> CFRules
+groupProds = addListToFM_C (++) emptyFM . map (\rs -> (ruleCat rs,[rs]))
+ where ruleCat (Rule c _ _) = c
+
+-- | Remove productions which use categories which have no productions
+removeEmptyCats :: CFRules -> CFRules
+removeEmptyCats rss = listToFM $ fix removeEmptyCats' $ fmToList rss
+ where
+ removeEmptyCats' :: [(String,[CFRule_])] -> [(String,[CFRule_])]
+ removeEmptyCats' rs = k'
+ where
+ keep = filter (not . null . snd) rs
+ allCats = nub [c | (_,r) <- rs, Rule _ rhs _ <- r, Cat c <- rhs]
+ emptyCats = filter (nothingOrNull . flip lookup rs) allCats
+ k' = map (\ (c,xs) -> (c, filter (not . anyUsedBy emptyCats) xs)) keep
+
+anyUsedBy :: [String] -> CFRule_ -> Bool
+anyUsedBy ss (Rule _ r _) = or [c `elem` ss | Cat c <- r]
+
+removeLeftRecursion :: CFRules -> CFRules
+removeLeftRecursion rs = listToFM $ concatMap removeDirectLeftRecursion $ map handleProds $ fmToList rs
+ where
+ handleProds (c, r) = (c, concatMap handleProd r)
+ handleProd (Rule ai (Cat aj:alpha) n) | aj < ai =
+ -- FIXME: this will give multiple rules with the same name
+ [Rule ai (beta ++ alpha) n | Rule _ beta _ <- fromJust (lookupFM rs aj)]
+ handleProd r = [r]
+
+removeDirectLeftRecursion :: (String,[CFRule_]) -- ^ All productions for a category
+ -> [(String,[CFRule_])]
+removeDirectLeftRecursion (a,rs) | null dr = [(a,rs)]
+ | otherwise = [(a, as), (a', a's)]
+ where
+ a' = a ++ "'" -- FIXME: this might not be unique
+ (dr,nr) = partition isDirectLeftRecursive rs
+ as = maybeEndWithA' nr
+ is = [Rule a' (tail r) n | Rule _ r n <- dr]
+ a's = maybeEndWithA' is
+ maybeEndWithA' xs = xs ++ [Rule c (r++[Cat a']) n | Rule c r n <- xs]
+
+isDirectLeftRecursive :: CFRule_ -> Bool
+isDirectLeftRecursive (Rule c (Cat c':_) _) = c == c'
+isDirectLeftRecursive _ = False
+
+
+
+fix :: Eq a => (a -> a) -> a -> a
+fix f x = let x' = f x in if x' == x then x else fix f x'
+
+nothingOrNull :: Maybe [a] -> Bool
+nothingOrNull Nothing = True
+nothingOrNull (Just xs) = null xs \ No newline at end of file
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index 9df79e983..4fd12f12a 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -27,6 +27,7 @@ import PrGrammar
import PrOld
import MkGFC
import CFtoSRG
+import PrGSL (prGSL)
import Zipper
@@ -190,6 +191,7 @@ customGrammarPrinter =
,(strCI "cf", prCF . stateCF)
,(strCI "old", printGrammarOld . stateGrammarST)
,(strCI "srg", prSRG . stateCF)
+ ,(strCI "gsl", prGSL . Cnv.cfg . statePInfo)
,(strCI "lbnf", prLBNF . stateCF)
,(strCI "haskell", grammar2haskell . stateGrammarST)
,(strCI "morpho", prMorpho . stateMorpho)
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 08:01:46 +0000