"Committed_by_peb"

src/GF/Conversion/Prolog.hs

@@ -0,0 +1,174 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/08/11 14:11:46 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Converting/Printing different grammar formalisms in Prolog-readable format
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.Prolog (prtSM_Multi,
+                             prtSGrammar, prtSMulti, prtSHeader, prtSRule,
+                             prtMGrammar, prtMMulti, prtMHeader, prtMRule,
+                             prtCGrammar, prtCMulti, prtCHeader, prtCRule) where
+
+import GF.Formalism.GCFG
+import GF.Formalism.SimpleGFC
+import GF.Formalism.MCFG
+import GF.Formalism.CFG
+import GF.Formalism.Utilities
+import GF.Conversion.Types
+import qualified GF.Conversion.GFC as Cnv
+
+import GF.Data.Operations ((++++), (+++++))
+import GF.Infra.Print
+import qualified GF.Infra.Modules as Mod
+import qualified GF.Infra.Option as Option
+import GF.Data.Operations (okError)
+import GF.Canon.AbsGFC (Flag(..))
+import GF.Canon.GFC (CanonGrammar)
+import GF.Infra.Ident (Ident(..))
+
+import Data.Maybe (maybeToList, listToMaybe)
+
+----------------------------------------------------------------------
+-- | printing multiple languages at the same time
+
+prtSM_Multi, prtSMulti, prtMMulti, prtCMulti :: Option.Options -> CanonGrammar -> String
+prtSMulti = prtMulti prtSHeader prtSRule (const Cnv.gfc2simple) ""
+prtMMulti = prtMulti prtMHeader prtMRule Cnv.gfc2mcfg "{}[.s]"
+prtCMulti = prtMulti prtCHeader prtCRule Cnv.gfc2cfg "{}.s"
+
+prtSM_Multi opts gr = prtSMulti opts gr +++++ prtMMulti opts gr
+
+-- code and ideas stolen from GF.CFGM.PrintCFGrammar
+
+prtMulti prtHeader prtRule conversion startsuffix opts gr
+    = prtHeader ++++ unlines
+      [ "\n\n" ++ prtLine ++++
+        "%% Language module: " ++ prtQ langmod +++++
+        unlines (map (prtRule langmod) rules) |
+        lang <- maybe [] (Mod.allConcretes gr) (Mod.greatestAbstract gr),
+        let Mod.ModMod (Mod.Module{Mod.flags=fs}) = okError (Mod.lookupModule gr lang),
+        let cnvopts = Option.Opts $ map Option.gfcConversion $ getFlag fs "conversion",
+        let rules = conversion cnvopts (gr, lang),
+        let langmod = (let IC lg = lang in "gf_" ++ lg) ]
+
+getFlag :: [Flag] -> String -> [String]
+getFlag fs x = [v | Flg (IC k) (IC v) <- fs, k == x]
+
+----------------------------------------------------------------------
+-- | SimpleGFC to Prolog
+--
+-- assumes that the profiles in the Simple GFC names are trivial
+prtSGrammar :: SGrammar -> String
+prtSGrammar rules = prtSHeader +++++ unlines (map (prtSRule "") rules)
+
+prtSHeader :: String
+prtSHeader = prtLine ++++
+             "%% Simple GFC grammar in Prolog-readable format" ++++
+             "%% Autogenerated from the Grammatical Framework" +++++
+             "%% Operators used in LinTerms:" ++++
+             ":- op(200, xfx, [':.', ':/', ':++', ':^'])." +++++
+             "%% The following predicate is defined:" ++++
+             "%% \t gfcrule(Fun, Cat, [Cat,...], LinTerm)"
+
+prtSRule :: String -> SRule -> String
+prtSRule lang (Rule (Abs cat cats (Name fun _prof)) (Cnc _ _ mterm)) 
+    = (if null lang then "" else prtQ lang ++ " : ") ++ 
+      "gfcrule(" ++ plname ++ ", " ++ plcat ++ ", " ++ plcats ++ ", " ++ plcnc ++ ")."
+    where plcat  = prtQ cat
+          plcats = "[" ++ prtSep ", " (map prtQ cats) ++ "]"
+	  plname = prtQ fun
+          plcnc  = "\n\t" ++ prtSTerm (maybe (Variants []) id mterm)
+
+prtSTerm (Arg n c p)    = "arg(" ++ prtQ c ++ "," ++ prtSPath p ++ "," ++ prt n ++ ")"
+-- prtSTerm (c :^ [])   = prtQ c
+prtSTerm (c :^ ts)      = "(" ++ prtQ c ++ " :^ [" ++ prtSep ", " (map prtSTerm ts) ++ "])"
+prtSTerm (Rec rec)      = "rec([" ++ prtSep ", " [ prtQ l ++ "=" ++ prtSTerm t | (l, t) <- rec ] ++ "])"
+prtSTerm (Tbl tbl)      = "tbl([" ++ prtSep ", " [ prtSTerm p ++ "=" ++ prtSTerm t | (p, t) <- tbl ] ++ "])"
+prtSTerm (Variants ts)  = "variants([" ++ prtSep ", " (map prtSTerm ts) ++ "])"
+prtSTerm (t1 :++ t2)    = "(" ++ prtSTerm t1 ++ " :++ " ++ prtSTerm t2 ++ ")"
+prtSTerm (Token t)      = "token(" ++ prtQ t ++ ")"
+prtSTerm (Empty)        = "empty"
+prtSTerm (term :. lbl)  = "(" ++ prtSTerm term ++ " :. " ++ prtQ lbl ++ ")"
+prtSTerm (term :! sel)  = "(" ++ prtSTerm term ++ " :/ " ++ prtSTerm sel ++ ")"
+-- prtSTerm (Wildcard)  = "wildcard"
+-- prtSTerm (Var var)   = "var(" ++ prtQ var ++ ")"
+
+prtSPath (Path path) = "[" ++ prtSep "," (map (either prtQ prtSTerm) path) ++ "]"
+
+----------------------------------------------------------------------
+-- | MCFG to Prolog
+prtMGrammar :: MGrammar -> String
+prtMGrammar rules = prtMHeader +++++ unlines (map (prtMRule "") rules)
+
+prtMHeader :: String
+prtMHeader = prtLine ++++
+             "%% Multiple context-free grammar in Prolog-readable format" ++++
+             "%% Autogenerated from the Grammatical Framework" +++++
+             "%% The following predicate is defined:" ++++
+             "%% \t mcfgrule(Fun/ProfileList, Cat, [Cat,...], [Lbl=Symbols,...])" 
+
+prtMRule :: String -> MRule -> String
+prtMRule lang (Rule (Abs cat cats (Name fun profiles)) (Cnc _lcat _lcats lins)) 
+    = (if null lang then "" else prtQ lang ++ " : ") ++ 
+      "mcfgrule(" ++ plname ++ ", " ++ plcat ++ ", " ++ plcats ++ ", " ++ pllins ++ ")."
+    where plcat  = prtQ cat
+          plcats = "[" ++ prtSep ", " (map prtQ cats) ++ "]"
+	  plname = prtQ fun ++ "/[" ++ prtSep "," (map prtProfile profiles) ++ "]"
+          pllins = "\n\t[ " ++ prtSep "\n\t, " (map prtMLin lins) ++ " ]"
+
+prtMLin (Lin lbl lin) = prtQ lbl ++ " = [" ++ prtSep ", " (map prtMSymbol lin) ++ "]"
+
+prtMSymbol (Cat (cat, lbl, nr)) = "cat(" ++ prtQ cat ++ "," ++ prtQ lbl ++ "," ++ show nr ++ ")"
+prtMSymbol (Tok tok) = "tok(" ++ prtQ tok ++ ")"
+
+----------------------------------------------------------------------
+-- | CFG to Prolog
+prtCGrammar :: CGrammar -> String
+prtCGrammar rules = prtCHeader +++++ unlines (map (prtCRule "") rules)
+
+prtCHeader :: String
+prtCHeader = prtLine ++++
+             "%% Context-free grammar in Prolog-readable format" ++++
+             "%% Autogenerated from the Grammatical Framework" +++++
+             "%% The following predicate is defined:" ++++
+             "%% \t cfgrule(Fun/ProfileList, Cat, [Symbol,...])"
+
+prtCRule :: String -> CRule -> String
+prtCRule lang (CFRule cat syms (Name fun profiles)) 
+    = (if null lang then "" else prtQ lang ++ " : ") ++ 
+      "cfgrule(" ++ plname ++ ", " ++ plcat ++ ", " ++ plsyms ++ ")."
+    where plcat  = prtQ cat
+          plsyms = "[" ++ prtSep ", " (map prtCSymbol syms) ++ "]"
+          plname = prtQ fun ++ "/[" ++ prtSep "," (map prtProfile profiles) ++ "]" 
+
+prtCSymbol (Cat cat) = "cat(" ++ prtQ cat ++ ")"
+prtCSymbol (Tok tok) = "tok(" ++ prtQ tok ++ ")"
+
+----------------------------------------------------------------------
+-- profiles, quoted strings and more
+
+prtProfile (Unify args) = show args
+prtProfile (Constant forest) = prtForest forest
+
+prtForest (FMeta) = "_META_"
+prtForest (FNode fun fss) = prtQ fun ++ "^" ++ prtFss fss
+    where prtFss fss = "[" ++ prtSep "," (map prtFs fss) ++ "]"
+	  prtFs fs = "[" ++ prtSep "," (map prtForest fs) ++ "]"
+
+prtQ x = "'" ++ concatMap esc (prt x) ++ "'"
+    where esc '\'' = "\\'"
+          esc '\n' = "\\n"
+          esc '\t' = "\\t"
+          esc c = [c]
+
+prtLine = replicate 70 '%'
+
+