"Committed_by_peb"

src/GF/Conversion/Prolog.hs

@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/08/18 13:18:10 $ 
+-- > CVS $Date: 2005/09/01 09:53:19 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.2 $
+-- > CVS $Revision: 1.3 $
 --
 -- Converting/Printing different grammar formalisms in Prolog-readable format
 -----------------------------------------------------------------------------
@@ -34,12 +34,13 @@ import GF.Canon.GFC (CanonGrammar)
 import GF.Infra.Ident (Ident(..))
 
 import Data.Maybe (maybeToList, listToMaybe)
+import Data.Char (isLower, isAlphaNum)
 
 ----------------------------------------------------------------------
 -- | printing multiple languages at the same time
 
 prtSMulti, prtMMulti, prtCMulti :: Option.Options -> CanonGrammar -> String
-prtSMulti = prtMulti prtSHeader prtSRule (const Cnv.gfc2simple)
+prtSMulti = prtMulti prtSHeader prtSRule Cnv.gfc2simple
 prtMMulti = prtMulti prtMHeader prtMRule Cnv.gfc2mcfg
 prtCMulti = prtMulti prtCHeader prtCRule Cnv.gfc2cfg
 
@@ -78,9 +79,9 @@ 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)
+          plcat  = prtSCat cat
+          plcats = prtFunctor "c" (map prtSCat cats) 
+	  plcnc  = "\n\t" ++ prtSTerm (maybe Empty id mterm)
 
 prtSTerm (Arg n c p)    = prtFunctor "arg" [prtQ c, prtSPath p, prt (n+1)]
 -- prtSTerm (c :^ [])   = prtQ c
@@ -98,6 +99,13 @@ prtSTerm (term :! sel)  = prtOper "/" (prtSTerm term) (prtSTerm sel)
 
 prtSPath (Path path) = prtPList (map (either prtQ prtSTerm) path)
 
+prtSCat (Decl var cat args)     = prVar ++ prtFunctor (prtQ cat) (map prtSTTerm args)
+    where prVar | var == anyVar = ""
+                | otherwise     = "_" ++ prt var ++ ":"
+
+prtSTTerm (con :@ args) = prtFunctor (prtQ con) (map prtSTTerm args)
+prtSTTerm (TVar var)    = "_" ++ prt var
+
 ----------------------------------------------------------------------
 -- | MCFG to Prolog
 prtMGrammar :: MGrammar -> String
@@ -108,14 +116,13 @@ 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,...])" 
+             "%% \t mcfgrule(Fun(Profile,...), Cat, c(Cat,...), [Lbl=Symbols,...])" 
 
 prtMRule :: String -> MRule -> String
-prtMRule lang (Rule (Abs cat cats (Name fun profiles)) (Cnc _lcat _lcats lins)) 
+prtMRule lang (Rule (Abs cat cats name) (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) 
+      prtFunctor "mcfgrule" [plname, plcat, plcats, pllins] ++ "."
+    where plname = prtName name
           plcat  = prtQ cat
           plcats = prtFunctor "c" (map prtQ cats) 
           pllins = "\n\t[ " ++ prtSep "\n\t, " (map prtMLin lins) ++ " ]"
@@ -135,14 +142,13 @@ 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,...])"
+             "%% \t cfgrule(Fun(Profile,...), Cat, [Symbol,...])"
 
 prtCRule :: String -> CRule -> String
-prtCRule lang (CFRule cat syms (Name fun profiles)) 
+prtCRule lang (CFRule cat syms name)
     = (if null lang then "" else prtQ lang ++ " : ") ++ 
-      prtFunctor "cfgrule" [plfun, plprof, plcat, plsyms] ++ "."
-    where plfun  = prtQ fun
-          plprof = prtFunctor "p" (map prtProfile profiles) 
+      prtFunctor "cfgrule" [plname, plcat, plsyms] ++ "."
+    where plname = prtName name
           plcat  = prtQ cat
           plsyms = prtPList (map prtCSymbol syms) 
 
@@ -156,16 +162,26 @@ 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)
+prtName (Name fun profiles)
+    | and (zipWith (==) profiles (map (Unify . return) [0..])) = prtQ fun
+    | otherwise = prtFunctor (prtQ fun) (map prtProfile profiles) 
+
+prtProfile (Unify []) = " ? "
+prtProfile (Unify args) = foldr1 (prtOper "=") (map (show . 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) 
+prtForest (FMeta) = " ? "
+prtForest (FNode fun [fs]) = prtFunctor (prtQ fun) (prtPList (map prtForest fs))
+prtForest (FNode fun fss) = prtPList [ prtFunctor (prtQ fun) (prtPList (map prtForest fs)) |
+                                       fs <- fss ]
 
-prtQ x = "'" ++ concatMap esc (prt x) ++ "'"
+prtQ atom = prtQStr (prt atom)
+
+prtQStr atom@(x:xs) 
+    | isLower x && all isAlphaNumUnder xs = atom
+    where isAlphaNumUnder '_' = True
+          isAlphaNumUnder x = isAlphaNum x
+prtQStr atom =  "'" ++ concatMap esc (prt atom) ++ "'"
     where esc '\'' = "\\'"
           esc '\n' = "\\n"
           esc '\t' = "\\t"