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 -plFact :: String -> [String] -> String -plFact fun args = plTerm fun args ++ "." +plCat :: Int -> String +plCat n = plAtom ('c' : show n) + +plFun :: Int -> String +plFun n = plAtom ('f' : show n) + +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"),