GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 11:42:49 -06:00
Code Issues Packages Projects Releases Wiki Activity

major changes to the prolog export

Browse Source
This commit is contained in:
peter.ljunglof
2012-06-27 23:29:05 +00:00
parent 871eb6eabc
commit 035b7731e5
3 changed files with 115 additions and 92 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
src/compiler/GF/Compile/Export.hs
View File

@@ -36,7 +36,6 @@ exportPGF opts fmt pgf =
FmtPython -> multi "py" pgf2python FmtPython -> multi "py" pgf2python
FmtHaskell -> multi "hs" (grammar2haskell opts name) FmtHaskell -> multi "hs" (grammar2haskell opts name)
FmtProlog -> multi "pl" grammar2prolog FmtProlog -> multi "pl" grammar2prolog
FmtProlog_Abs -> multi "pl" grammar2prolog_abs
FmtLambdaProlog -> multi "mod" grammar2lambdaprolog_mod ++ multi "sig" grammar2lambdaprolog_sig FmtLambdaProlog -> multi "mod" grammar2lambdaprolog_mod ++ multi "sig" grammar2lambdaprolog_sig
FmtBNF -> single "bnf" bnfPrinter FmtBNF -> single "bnf" bnfPrinter
FmtEBNF -> single "ebnf" (ebnfPrinter opts) FmtEBNF -> single "ebnf" (ebnfPrinter opts)

204
src/compiler/GF/Compile/PGFtoProlog.hs
View File

@@ -1,14 +1,12 @@
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- | -- |
-- Module : PGFtoProlog -- Module : PGFtoProlog
-- Maintainer : Peter Ljunglöf -- Maintainer : Peter Ljunglöf
-- Stability : (stable)
-- Portability : (portable)
-- --
-- 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.CId
import PGF.Data import PGF.Data
@@ -16,90 +14,98 @@ import PGF.Macros
import GF.Data.Operations import GF.Data.Operations
import qualified Data.Array.IArray as Array
import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper, ord) import qualified Data.IntMap as IntMap
import Data.List (isPrefixOf,mapAccumL) 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 -- abstract syntax
plAbstract :: (CId, Abstr) -> [String] plAbstract :: CId -> Abstr -> String
plAbstract (name, Abstr aflags funs cats) = plAbstract name abs
["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%", = (plHeader "Abstract syntax" ++++
"%% abstract module: " ++ plp name] ++ plFacts name "flag" 2 "(?Flag, ?Value): flags for abstract syntax"
clauseHeader "%% absflag(?Flag, ?Value): flags for abstract syntax" [[plp f, plp v] |
(map (plpFact2 "absflag") (Map.assocs aflags)) ++ (f, v) <- Map.assocs (aflags abs)] ++++
clauseHeader "%% cat(?Type, ?[X:Type,...])" plFacts name "cat" 2 "(?Type, ?[X:Type,...])"
(map plCat (Map.assocs cats)) ++ [[plType cat args, plHypos hypos'] |
clauseHeader "%% fun(?Fun, ?Type, ?[X:Type,...])" (cat, (hypos, _)) <- Map.assocs (cats abs),
(map plFun (Map.assocs funs)) ++ let ((_, subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos,
clauseHeader "%% def(?Fun, ?Expr)" let args = reverse [EFun x | (_,x) <- subst]] ++++
(concatMap plFundef (Map.assocs funs)) plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])"
[[plp fun, plType cat args, plHypos hypos] |
plCat :: (CId, ([Hypo],[(Double,CId)])) -> String (fun, (typ, _, _, _)) <- Map.assocs (funs abs),
plCat (cat, (hypos,_)) = plFact "cat" (plTypeWithHypos typ) let (_, DTyp hypos cat args) = alphaConvert emptyEnv typ] ++++
where ((_,subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos plFacts name "def" 2 "(?Fun, ?Expr)"
args = reverse [EFun x | (_,x) <- subst] [[plp fun, plp expr] |
typ = DTyp hypos' cat args (fun, (_, _, Just eqs, _)) <- Map.assocs (funs abs),
let (_, expr) = alphaConvert emptyEnv eqs]
plFun :: (CId, (Type, Int, Maybe [Equation], Double)) -> String )
plFun (fun, (typ,_,_,_)) = plFact "fun" (plp fun : plTypeWithHypos typ') where plType cat args = plTerm (plp cat) (map plp args)
where typ' = snd $ alphaConvert emptyEnv typ plHypos hypos = plList [plOper ":" (plp x) (plp ty) | (_, x, ty) <- hypos]
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
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- concrete syntax -- concrete syntax
plConcrete :: (CId, Concr) -> [String] plConcrete :: (CId, Concr) -> String
plConcrete (cncname, cnc) = plConcrete (name, cnc)
["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%", = (plHeader ("Concrete syntax: " ++ plp name) ++++
"%% concrete module: " ++ plp cncname] ++ plFacts name "flag" 2 "(?Flag, ?Value): flags for concrete syntax"
clauseHeader "%% cncflag(?Flag, ?Value): flags for concrete syntax" [[plp f, plp v] |
(map (mod . plpFact2 "cncflag") (Map.assocs (cflags cnc))) (f, v) <- Map.assocs (cflags cnc)] ++++
where mod clause = plp cncname ++ ": " ++ clause 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 -- prolog-printing pgf datatypes
instance PLPrint Type where instance PLPrint Type where
plp (DTyp hypos cat args) | null hypos = result plp (DTyp hypos cat args)
| otherwise = plOper " -> " (plList (map (\(_,x,ty) -> plOper ":" (plp x) (plp ty)) hypos)) result | null hypos = result
| otherwise = plOper " -> " plHypos result
where result = plTerm (plp cat) (map plp args) where result = plTerm (plp cat) (map plp args)
plHypos = plList [plOper ":" (plp x) (plp ty) | (_,x,ty) <- hypos]
instance PLPrint Expr where instance PLPrint Expr where
plp (EFun x) = plp x plp (EFun x) = plp x
@@ -114,12 +120,11 @@ instance PLPrint Patt where
plp (PLit lit) = plp lit plp (PLit lit) = plp lit
instance PLPrint Equation where 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 instance PLPrint CId where
plp cid | isLogicalVariable str || plp cid | isLogicalVariable str || cid == wildCId = plVar str
cid == wildCId = plVar str | otherwise = plAtom str
| otherwise = plAtom str
where str = showCId cid where str = showCId cid
instance PLPrint Literal where instance PLPrint Literal where
@@ -127,8 +132,13 @@ instance PLPrint Literal where
plp (LInt n) = plp (show n) plp (LInt n) = plp (show n)
plp (LFlt f) = plp (show f) plp (LFlt f) = plp (show f)
---------------------------------------------------------------------- instance PLPrint Symbol where
-- basic prolog-printing 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 class PLPrint a where
plp :: a -> String plp :: a -> String
@@ -142,17 +152,32 @@ instance PLPrint Char where
instance PLPrint a => PLPrint [a] where instance PLPrint a => PLPrint [a] where
plp = plps 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 plCat :: Int -> String
plFact fun args = plTerm fun args ++ "." 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 :: String -> [String] -> String
plTerm fun args = plAtom fun ++ prParenth (prTList ", " args) plTerm fun args = plAtom fun ++ prParenth (prTList ", " args)
plList :: [String] -> String plList :: [String] -> String
plList = prBracket . prTList "," plList xs = prBracket (prTList "," xs)
plOper :: String -> String -> String -> String plOper :: String -> String -> String -> String
plOper op a b = prParenth (a ++ op ++ b) plOper op a b = prParenth (a ++ op ++ b)
@@ -168,13 +193,14 @@ plAtom :: String -> String
plAtom "" = "''" plAtom "" = "''"
plAtom atom@(c:cs) | isAsciiLower c && all isAlphaNumUnderscore cs plAtom atom@(c:cs) | isAsciiLower c && all isAlphaNumUnderscore cs
|| c == '\'' && cs /= "" && last cs == '\'' = atom || c == '\'' && cs /= "" && last cs == '\'' = atom
| otherwise = "'" ++ concatMap changeQuote atom ++ "'" | otherwise = "'" ++ changeQuote atom ++ "'"
where changeQuote '\'' = "\\'" where changeQuote ('\'':cs) = '\\' : '\'' : changeQuote cs
changeQuote c = [c] changeQuote ('\\':cs) = '\\' : '\\' : changeQuote cs
changeQuote (c:cs) = c : changeQuote cs
changeQuote "" = ""
isAlphaNumUnderscore :: Char -> Bool isAlphaNumUnderscore :: Char -> Bool
isAlphaNumUnderscore c = isAlphaNum c || c == '_' isAlphaNumUnderscore c = (isAscii c && isAlphaNum c) || c == '_'
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- prolog variables -- prolog variables

2
src/compiler/GF/Infra/Option.hs
View File

@@ -88,7 +88,6 @@ data OutputFormat = FmtPGFPretty
| FmtPython | FmtPython
| FmtHaskell | FmtHaskell
| FmtProlog | FmtProlog
| FmtProlog_Abs
| FmtLambdaProlog | FmtLambdaProlog
| FmtBNF | FmtBNF
| FmtEBNF | FmtEBNF
@@ -436,7 +435,6 @@ outputFormatsExpl =
(("python", FmtPython),"Python (whole grammar)"), (("python", FmtPython),"Python (whole grammar)"),
(("haskell", FmtHaskell),"Haskell (abstract syntax)"), (("haskell", FmtHaskell),"Haskell (abstract syntax)"),
(("prolog", FmtProlog),"Prolog (whole grammar)"), (("prolog", FmtProlog),"Prolog (whole grammar)"),
(("prolog_abs", FmtProlog_Abs),"Prolog (abstract syntax)"),
(("lambda_prolog",FmtLambdaProlog),"LambdaProlog (abstract syntax)"), (("lambda_prolog",FmtLambdaProlog),"LambdaProlog (abstract syntax)"),
(("bnf", FmtBNF),"BNF (context-free grammar)"), (("bnf", FmtBNF),"BNF (context-free grammar)"),
(("ebnf", FmtEBNF),"Extended BNF"), (("ebnf", FmtEBNF),"Extended BNF"),