----------------------------------------------------------------------
-- |
-- Maintainer  : PL
-- Stability   : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/08/18 13:18:10 $ 
-- > CVS $Author: peb $
-- > CVS $Revision: 1.2 $
--
-- Converting/Printing different grammar formalisms in Prolog-readable format
-----------------------------------------------------------------------------


module GF.Conversion.Prolog (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

prtSMulti, prtMMulti, prtCMulti :: Option.Options -> CanonGrammar -> String
prtSMulti = prtMulti prtSHeader prtSRule (const Cnv.gfc2simple)
prtMMulti = prtMulti prtMHeader prtMRule Cnv.gfc2mcfg
prtCMulti = prtMulti prtCHeader prtCRule Cnv.gfc2cfg

-- code and ideas stolen from GF.CFGM.PrintCFGrammar

prtMulti prtHeader prtRule conversion 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" +++++
             "%% The following predicate is defined:" ++++
             "%% \t gfcrule(Fun, Cat, c(Cat,...), LinTerm)"

prtSRule :: String -> SRule -> String
prtSRule lang (Rule (Abs cat cats (Name fun _prof)) (Cnc _ _ mterm)) 
    = (if null lang then "" else prtQ lang ++ " : ") ++ 
      prtFunctor "gfcrule" [plfun, plcat, plcats, plcnc] ++ "."
    where plfun  = prtQ fun
          plcat  = prtQ cat
          plcats = prtFunctor "c" (map prtQ cats) 
	  plcnc  = "\n\t" ++ prtSTerm (maybe (Variants []) id mterm)

prtSTerm (Arg n c p)    = prtFunctor "arg" [prtQ c, prtSPath p, prt (n+1)]
-- prtSTerm (c :^ [])   = prtQ c
prtSTerm (c :^ ts)      = prtOper "^" (prtQ c) (prtPList (map prtSTerm ts))
prtSTerm (Rec rec)      = prtFunctor "rec" [prtPList [ prtOper "=" (prtQ l) (prtSTerm t) | (l, t) <- rec ]]
prtSTerm (Tbl tbl)      = prtFunctor "tbl" [prtPList [ prtOper "=" (prtSTerm p) (prtSTerm t) | (p, t) <- tbl ]]
prtSTerm (Variants ts)  = prtFunctor "variants" [prtPList (map prtSTerm ts)]
prtSTerm (t1 :++ t2)    = prtOper "+" (prtSTerm t1) (prtSTerm t2)
prtSTerm (Token t)      = prtFunctor "token" [prtQ t]
prtSTerm (Empty)        = "empty"
prtSTerm (term :. lbl)  = prtOper "*" (prtSTerm term) (prtQ lbl)
prtSTerm (term :! sel)  = prtOper "/" (prtSTerm term) (prtSTerm sel)
-- prtSTerm (Wildcard)  = "wildcard"
-- prtSTerm (Var var)   = prtFunctor "var" [prtQ var]

prtSPath (Path path) = prtPList (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, p(Profile,...), Cat, c(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 ++ " : ") ++ 
      prtFunctor "mcfgrule" [plfun, plprof, plcat, plcats, pllins] ++ "."
    where plfun  = prtQ fun
          plprof = prtFunctor "p" (map prtProfile profiles) 
          plcat  = prtQ cat
          plcats = prtFunctor "c" (map prtQ cats) 
          pllins = "\n\t[ " ++ prtSep "\n\t, " (map prtMLin lins) ++ " ]"

prtMLin (Lin lbl lin) = prtOper "=" (prtQ lbl) (prtPList (map prtMSymbol lin))

prtMSymbol (Cat (cat, lbl, nr)) = prtFunctor "cat" [prtQ cat, prtQ lbl, show (nr+1)]
prtMSymbol (Tok tok) = prtFunctor "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, p(Profile,...), Cat, [Symbol,...])"

prtCRule :: String -> CRule -> String
prtCRule lang (CFRule cat syms (Name fun profiles)) 
    = (if null lang then "" else prtQ lang ++ " : ") ++ 
      prtFunctor "cfgrule" [plfun, plprof, plcat, plsyms] ++ "."
    where plfun  = prtQ fun
          plprof = prtFunctor "p" (map prtProfile profiles) 
          plcat  = prtQ cat
          plsyms = prtPList (map prtCSymbol syms) 

prtCSymbol (Cat cat) = prtFunctor "cat" [prtQ cat]
prtCSymbol (Tok tok) = prtFunctor "tok" [prtQ tok]

----------------------------------------------------------------------
-- profiles, quoted strings and more

prtFunctor f xs = f ++ if null xs then "" else "(" ++ prtSep ", " xs ++ ")"
prtPList     xs = "[" ++ prtSep ", " xs ++ "]"
prtOper   f x y = "(" ++ x ++ " " ++ f ++ " " ++ y ++ ")"

prtProfile (Unify [arg]) = show (succ arg)
prtProfile (Unify args)  = show (map succ args)
prtProfile (Constant forest) = prtForest forest

prtForest (FMeta) = "fmeta"
prtForest (FNode fun fss) = prtFunctor "fnode" [prtQ fun, prtFss fss]
    where prtFss fss = prtPList (map prtFs fss) 
	  prtFs  fs  = prtPList (map prtForest fs) 

prtQ x = "'" ++ concatMap esc (prt x) ++ "'"
    where esc '\'' = "\\'"
          esc '\n' = "\\n"
          esc '\t' = "\\t"
          esc c = [c]

prtLine = replicate 70 '%'