mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-24 03:52:50 -06:00
major changes to the prolog export
This commit is contained in:
peter.ljunglof
@@ -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)
|
||||
|
||||
@@ -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 qualified Data.IntMap as IntMap
|
||||
import Data.Char (isAlphaNum, isAscii, 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
|
||||
|
||||
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
|
||||
@@ -117,8 +123,7 @@ instance PLPrint Equation where
|
||||
plp (Equ patterns result) = plOper ":" (plp patterns) (plp result)
|
||||
|
||||
instance PLPrint CId where
|
||||
plp cid | isLogicalVariable str ||
|
||||
cid == wildCId = plVar str
|
||||
plp cid | isLogicalVariable str || cid == wildCId = plVar str
|
||||
| otherwise = plAtom str
|
||||
where str = showCId cid
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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"),
|
||||
|
||||
Reference in New Issue
Block a user