mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-15 07:49:31 -06:00
175 lines
7.2 KiB
Haskell
175 lines
7.2 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- 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 '%'
|
|
|
|
|