major changes to the prolog export

3 files changed, 116 insertions, 93 deletions

diff --git a/src/compiler/GF/Compile/Export.hs b/src/compiler/GF/Compile/Export.hs
index 347a1efb7..b7f00677f 100644
--- a/src/compiler/GF/Compile/Export.hs
+++ b/src/compiler/GF/Compile/Export.hs
@@ -36,7 +36,6 @@ exportPGF opts fmt pgf =
       FmtPython       -> multi "py"  pgf2python
       FmtHaskell      -> multi "hs"  (grammar2haskell opts name)
       FmtProlog       -> multi "pl"  grammar2prolog
-      FmtProlog_Abs   -> multi "pl"  grammar2prolog_abs
       FmtLambdaProlog -> multi "mod" grammar2lambdaprolog_mod ++ multi "sig" grammar2lambdaprolog_sig
       FmtBNF          -> single "bnf"   bnfPrinter
       FmtEBNF         -> single "ebnf"  (ebnfPrinter opts)
diff --git a/src/compiler/GF/Compile/PGFtoProlog.hs b/src/compiler/GF/Compile/PGFtoProlog.hs
index 9f456ca93..d24aa34c7 100644
--- a/src/compiler/GF/Compile/PGFtoProlog.hs
+++ b/src/compiler/GF/Compile/PGFtoProlog.hs
@@ -1,14 +1,12 @@
 ----------------------------------------------------------------------
 -- |
 -- Module      : PGFtoProlog
--- Maintainer  : Peter Ljunglöf
--- Stability   : (stable)
--- Portability : (portable)
+-- Maintainer  : Peter Ljunglöf
 --
--- to write a GF grammar into a Prolog module
+-- exports a GF grammar into a Prolog module
 -----------------------------------------------------------------------------
 
-module GF.Compile.PGFtoProlog (grammar2prolog, grammar2prolog_abs) where
+module GF.Compile.PGFtoProlog (grammar2prolog) where
 
 import PGF.CId
 import PGF.Data
@@ -16,90 +14,98 @@ import PGF.Macros
 
 import GF.Data.Operations
 
+import qualified Data.Array.IArray as Array
+import qualified Data.Set as Set
 import qualified Data.Map as Map
-import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper, ord)
-import Data.List (isPrefixOf,mapAccumL)
-
-grammar2prolog, grammar2prolog_abs :: PGF -> String
--- Most prologs have problems with UTF8 encodings, so we skip that:
-grammar2prolog     = {- encodeUTF8 . -} foldr (++++) [] . pgf2clauses 
-grammar2prolog_abs = {- encodeUTF8 . -} foldr (++++) [] . pgf2clauses_abs 
-
-
-pgf2clauses :: PGF -> [String]
-pgf2clauses (PGF gflags absname abstract concretes) =
-    [":- " ++ plFact "module" [plp absname, "[]"]] ++
-    clauseHeader "%% flag(?Flag, ?Value): global flags"
-                     (map (plpFact2 "flag") (Map.assocs gflags)) ++
-    plAbstract (absname, abstract) ++
-    concatMap plConcrete (Map.assocs concretes)
-
-pgf2clauses_abs :: PGF -> [String]
-pgf2clauses_abs (PGF gflags absname abstract _concretes) =
-    [":- " ++ plFact "module" [plp absname, "[]"]] ++
-    clauseHeader "%% flag(?Flag, ?Value): global flags"
-                     (map (plpFact2 "flag") (Map.assocs gflags)) ++
-    plAbstract (absname, abstract)
-
-clauseHeader :: String -> [String] -> [String]
-clauseHeader hdr [] = []
-clauseHeader hdr clauses = "":hdr:clauses
-
+import qualified Data.IntMap as IntMap
+import Data.Char (isAlphaNum, isAscii, isAsciiLower, isAsciiUpper, ord)
+import Data.List (isPrefixOf, mapAccumL)
+
+grammar2prolog :: PGF -> String
+grammar2prolog pgf
+    = ("%% This file was automatically generated by GF" +++++
+       ":- style_check(-singleton)" +++++
+       plFacts wildCId "abstract" 1 "(?AbstractName)"
+                   [[plp name]] ++++
+       plFacts wildCId "concrete" 2 "(?AbstractName, ?ConcreteName)" 
+                   [[plp name, plp cncname] | 
+                    cncname <- Map.keys (concretes pgf)] ++++
+       plFacts wildCId "flag" 2 "(?Flag, ?Value): global flags" 
+                   [[plp f, plp v] | 
+                    (f, v) <- Map.assocs (gflags pgf)] ++++
+       plAbstract name (abstract pgf) ++++
+       unlines (map plConcrete (Map.assocs (concretes pgf)))
+      )
+    where name = absname pgf
 
 ----------------------------------------------------------------------
 -- abstract syntax
 
-plAbstract :: (CId, Abstr) -> [String]
-plAbstract (name, Abstr aflags funs cats) =
-    ["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%",
-     "%% abstract module: " ++ plp name] ++
-    clauseHeader "%% absflag(?Flag, ?Value): flags for abstract syntax"
-                     (map (plpFact2 "absflag") (Map.assocs aflags)) ++ 
-    clauseHeader "%% cat(?Type, ?[X:Type,...])" 
-                     (map plCat (Map.assocs cats)) ++ 
-    clauseHeader "%% fun(?Fun, ?Type, ?[X:Type,...])"
-                     (map plFun (Map.assocs funs)) ++
-    clauseHeader "%% def(?Fun, ?Expr)" 
-                     (concatMap plFundef (Map.assocs funs))
-
-plCat :: (CId, ([Hypo],[(Double,CId)])) -> String
-plCat (cat, (hypos,_)) = plFact "cat" (plTypeWithHypos typ) 
-    where ((_,subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos
-          args = reverse [EFun x | (_,x) <- subst]
-          typ = DTyp hypos' cat args
-
-plFun :: (CId, (Type, Int, Maybe [Equation], Double)) -> String
-plFun (fun, (typ,_,_,_)) = plFact "fun" (plp fun : plTypeWithHypos typ')
-    where typ' = snd $ alphaConvert emptyEnv typ
-
-plTypeWithHypos :: Type -> [String]
-plTypeWithHypos (DTyp hypos cat args) = [plTerm (plp cat) (map plp args), plList (map (\(_,x,ty) -> plOper ":" (plp x) (plp ty)) hypos)]
-
-plFundef :: (CId, (Type,Int,Maybe [Equation],Double)) -> [String]
-plFundef (fun, (_,_,Nothing ,_)) = []
-plFundef (fun, (_,_,Just eqs,_)) = [plFact "def" [plp fun, plp fundef']]
-    where fundef' = snd $ alphaConvert emptyEnv eqs
-
+plAbstract :: CId -> Abstr -> String
+plAbstract name abs 
+    = (plHeader "Abstract syntax" ++++
+       plFacts name "flag" 2 "(?Flag, ?Value): flags for abstract syntax"
+                   [[plp f, plp v] | 
+                    (f, v) <- Map.assocs (aflags abs)] ++++
+       plFacts name "cat" 2 "(?Type, ?[X:Type,...])"
+                   [[plType cat args, plHypos hypos'] |
+                    (cat, (hypos, _)) <- Map.assocs (cats abs),
+                    let ((_, subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos,
+                        let args = reverse [EFun x | (_,x) <- subst]] ++++
+       plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])"
+                   [[plp fun, plType cat args, plHypos hypos] |
+                    (fun, (typ, _, _, _)) <- Map.assocs (funs abs),
+                    let (_, DTyp hypos cat args) = alphaConvert emptyEnv typ] ++++
+       plFacts name "def" 2 "(?Fun, ?Expr)" 
+                   [[plp fun, plp expr] |
+                    (fun, (_, _, Just eqs, _)) <- Map.assocs (funs abs),
+                    let (_, expr) = alphaConvert emptyEnv eqs]
+      )
+    where plType cat args = plTerm (plp cat) (map plp args)
+          plHypos hypos = plList [plOper ":" (plp x) (plp ty) | (_, x, ty) <- hypos]
 
 ----------------------------------------------------------------------
 -- concrete syntax
 
-plConcrete :: (CId, Concr) -> [String]
-plConcrete (cncname, cnc) =
-    ["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%",
-     "%% concrete module: " ++ plp cncname] ++
-    clauseHeader "%% cncflag(?Flag, ?Value): flags for concrete syntax"
-                     (map (mod . plpFact2 "cncflag") (Map.assocs (cflags cnc)))
-    where mod clause = plp cncname ++ ": " ++ clause
-
+plConcrete :: (CId, Concr) -> String
+plConcrete (name, cnc) 
+    = (plHeader ("Concrete syntax: " ++ plp name) ++++
+       plFacts name "flag" 2 "(?Flag, ?Value): flags for concrete syntax"
+                   [[plp f, plp v] | 
+                    (f, v) <- Map.assocs (cflags cnc)] ++++
+       plFacts name "printname" 2 "(?AbsFun/AbsCat, ?Atom)"
+                   [[plp f, plp n] | 
+                    (f, n) <- Map.assocs (printnames cnc)] ++++
+       plFacts name "lindef" 2 "(?CncCat, ?CncFun)"
+                   [[plCat cat, plFun fun] | 
+                    (cat, funs) <- IntMap.assocs (lindefs cnc),
+                    fun <- funs] ++++
+       plFacts name "prod" 3 "(?CncCat, ?CncFun, ?[CncCat])"
+                   [[plCat cat, fun, plTerm "c" (map plCat args)] |
+                    (cat, set) <- IntMap.toList (productions cnc),
+                    (fun, args) <- map plProduction (Set.toList set)] ++++
+       plFacts name "cncfun" 3 "(?CncFun, ?[Seq,...], ?AbsFun)"
+                   [[plFun fun, plTerm "s" (map plSeq (Array.elems lins)), plp absfun] |
+                    (fun, CncFun absfun lins) <- Array.assocs (cncfuns cnc)] ++++
+       plFacts name "seq" 2 "(?Seq, ?[Term])"
+                   [[plSeq seq, plp (Array.elems symbols)] |
+                    (seq, symbols) <- Array.assocs (sequences cnc)] ++++
+       plFacts name "cnccat" 2 "(?AbsCat, ?[CnCCat])" 
+                   [[plp cat, plList (map plCat [start..end])] |
+                    (cat, CncCat start end _) <- Map.assocs (cnccats cnc)]
+      )
+    where plProduction (PCoerce arg)       = ("-", [arg])
+          plProduction (PApply funid args) = (plFun funid, [fid | PArg hypos fid <- args])
 
 ----------------------------------------------------------------------
 -- prolog-printing pgf datatypes
 
 instance PLPrint Type where
-    plp (DTyp hypos cat args) | null hypos = result
-                              | otherwise  = plOper " -> " (plList (map (\(_,x,ty) -> plOper ":" (plp x) (plp ty)) hypos)) result
+    plp (DTyp hypos cat args) 
+        | null hypos = result
+        | otherwise  = plOper " -> " plHypos result
         where result = plTerm (plp cat) (map plp args)
+              plHypos = plList [plOper ":" (plp x) (plp ty) | (_,x,ty) <- hypos]
 
 instance PLPrint Expr where
     plp (EFun x)    = plp x
@@ -114,12 +120,11 @@ instance PLPrint Patt where
     plp (PLit lit)  = plp lit
 
 instance PLPrint Equation where
-    plp (Equ patterns result)   = plOper ":" (plp patterns) (plp result)
+    plp (Equ patterns result) = plOper ":" (plp patterns) (plp result)
 
 instance PLPrint CId where
-    plp cid | isLogicalVariable str || 
-              cid == wildCId = plVar str
-            | otherwise      = plAtom str
+    plp cid | isLogicalVariable str || cid == wildCId = plVar str
+            | otherwise = plAtom str
         where str = showCId cid
 
 instance PLPrint Literal where
@@ -127,8 +132,13 @@ instance PLPrint Literal where
     plp (LInt n) = plp (show n)
     plp (LFlt f) = plp (show f)
 
-----------------------------------------------------------------------
--- basic prolog-printing
+instance PLPrint Symbol where
+    plp (SymCat n l)    = plOper ":" (show n) (show l)
+    plp (SymLit n l)    = plTerm "lit" [show n, show l]
+    plp (SymVar n l)    = plTerm "var" [show n, show l]
+    plp (SymKS ts)      = prTList "," (map plAtom ts)
+    plp (SymKP ts alts) = plTerm "pre" [plList (map plAtom ts), plList (map plAlt alts)]
+        where plAlt (Alt ps ts) = plOper "/" (plList (map plAtom ps)) (plList (map plAtom ts))
 
 class PLPrint a where
     plp :: a -> String
@@ -142,17 +152,32 @@ instance PLPrint Char where
 instance PLPrint a => PLPrint [a] where
     plp = plps
 
-plpFact2 :: (PLPrint a, PLPrint b) => String -> (a, b) -> String
-plpFact2 fun (arg1, arg2) = plFact fun [plp arg1, plp arg2]
+----------------------------------------------------------------------
+-- other prolog-printing functions
+
+plCat :: Int -> String
+plCat n = plAtom ('c' : show n)
+
+plFun :: Int -> String
+plFun n = plAtom ('f' : show n)
 
-plFact :: String -> [String] -> String
-plFact fun args = plTerm fun args ++ "."
+plSeq :: Int -> String
+plSeq n = plAtom ('s' : show n)
+
+plHeader :: String -> String
+plHeader hdr = "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n%% " ++ hdr ++ "\n"
+
+plFacts :: CId -> String -> Int -> String -> [[String]] -> String
+plFacts mod pred arity comment facts = "%% " ++ pred ++ comment ++++ clauses
+    where clauses = (if facts == [] then ":- dynamic " ++ pred ++ "/" ++ show arity ++ ".\n"
+                     else unlines [mod' ++ plTerm pred args ++ "." | args <- facts])
+          mod' = if mod == wildCId then "" else plp mod ++ ": "
 
 plTerm :: String -> [String] -> String
 plTerm fun args = plAtom fun ++ prParenth (prTList ", " args)
 
 plList :: [String] -> String
-plList = prBracket . prTList "," 
+plList xs = prBracket (prTList "," xs)
 
 plOper :: String -> String -> String -> String
 plOper op a b = prParenth (a ++ op ++ b)
@@ -168,13 +193,14 @@ plAtom :: String -> String
 plAtom "" = "''"
 plAtom atom@(c:cs) | isAsciiLower c && all isAlphaNumUnderscore cs 
                      || c == '\'' && cs /= "" && last cs == '\''   = atom
-                   | otherwise = "'" ++ concatMap changeQuote atom ++ "'"
-    where changeQuote '\'' = "\\'"
-          changeQuote c = [c]
+                   | otherwise = "'" ++ changeQuote atom ++ "'"
+    where changeQuote ('\'':cs) = '\\' : '\'' : changeQuote cs
+          changeQuote ('\\':cs) = '\\' : '\\' : changeQuote cs
+          changeQuote (c:cs) = c : changeQuote cs
+          changeQuote "" = ""
 
 isAlphaNumUnderscore :: Char -> Bool
-isAlphaNumUnderscore c = isAlphaNum c || c == '_'
-
+isAlphaNumUnderscore c = (isAscii c && isAlphaNum c) || c == '_'
 
 ----------------------------------------------------------------------
 -- prolog variables 
diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index 75d0c33c6..79e1b9f73 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -88,7 +88,6 @@ data OutputFormat = FmtPGFPretty
                   | FmtPython 
                   | FmtHaskell 
                   | FmtProlog
-                  | FmtProlog_Abs
                   | FmtLambdaProlog
                   | FmtBNF
                   | FmtEBNF
@@ -436,7 +435,6 @@ outputFormatsExpl =
      (("python",       FmtPython),"Python (whole grammar)"),
      (("haskell",      FmtHaskell),"Haskell (abstract syntax)"),
      (("prolog",       FmtProlog),"Prolog (whole grammar)"),
-     (("prolog_abs",   FmtProlog_Abs),"Prolog (abstract syntax)"),
      (("lambda_prolog",FmtLambdaProlog),"LambdaProlog (abstract syntax)"),
      (("bnf",          FmtBNF),"BNF (context-free grammar)"),
      (("ebnf",         FmtEBNF),"Extended BNF"),