diff --git a/src/GF/Compile/Export.hs b/src/GF/Compile/Export.hs index f3e775ccf..bd4f88df4 100644 --- a/src/GF/Compile/Export.hs +++ b/src/GF/Compile/Export.hs @@ -5,6 +5,7 @@ import PGF.Data (PGF(..)) import PGF.Raw.Print (printTree) import PGF.Raw.Convert (fromPGF) import GF.Compile.GFCCtoHaskell +import GF.Compile.GFCCtoProlog import GF.Compile.GFCCtoJS import GF.Infra.Option import GF.Speech.CFG @@ -32,6 +33,8 @@ exportPGF opts fmt pgf = FmtJavaScript -> multi "js" pgf2js FmtHaskell -> multi "hs" (grammar2haskell name) FmtHaskell_GADT -> multi "hs" (grammar2haskellGADT name) + FmtProlog -> multi "pl" grammar2prolog + FmtProlog_Abs -> multi "pl" grammar2prolog_abs FmtBNF -> single "bnf" bnfPrinter FmtSRGS_XML -> single "grxml" (srgsXmlPrinter sisr) FmtSRGS_XML_NonRec -> single "grxml" srgsXmlNonRecursivePrinter diff --git a/src/GF/Compile/GFCCtoProlog.hs b/src/GF/Compile/GFCCtoProlog.hs new file mode 100644 index 000000000..ccf7fffc3 --- /dev/null +++ b/src/GF/Compile/GFCCtoProlog.hs @@ -0,0 +1,299 @@ +---------------------------------------------------------------------- +-- | +-- Module : GFCCtoProlog +-- Maintainer : Peter Ljunglöf +-- Stability : (stable) +-- Portability : (portable) +-- +-- to write a GF grammar into a Prolog module +----------------------------------------------------------------------------- + +module GF.Compile.GFCCtoProlog (grammar2prolog, grammar2prolog_abs) where + +import PGF.CId +import PGF.Data +import PGF.Macros + +import GF.Data.Operations +import GF.Text.UTF8 + +import qualified Data.Map as Map +import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper, ord) +import Data.List (isPrefixOf) + +grammar2prolog, grammar2prolog_abs :: PGF -> String +grammar2prolog = encodeUTF8 . foldr (++++) [] . pgf2clauses +grammar2prolog_abs = encodeUTF8 . foldr (++++) [] . pgf2clauses_abs + + +pgf2clauses :: PGF -> [String] +pgf2clauses (PGF absname cncnames gflags abstract concretes) = + [":- " ++ plFact "module" [plp absname, "[]"]] ++ + clauseHeader "%% concrete(?Module)" + [plFact "concrete" [plp cncname] | cncname <- cncnames] ++ + 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 absname _cncnames gflags 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 + + +---------------------------------------------------------------------- +-- abstract syntax + +plAbstract :: (CId, Abstr) -> [String] +plAbstract (name, Abstr aflags funs cats _catfuns) = + ["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%", + "%% 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]) -> String +plCat (cat, hypos) = plFact "cat" (plTypeWithHypos typ) + where ((_,subst), hypos') = alphaConvert emptyEnv hypos + args = reverse [EVar x | (_,x) <- subst] + typ = wildcardUnusedVars $ DTyp hypos' cat args + +plFun :: (CId, (Type, Expr)) -> String +plFun (fun, (typ, _)) = plFact "fun" (plp fun : plTypeWithHypos typ') + where typ' = wildcardUnusedVars $ snd $ alphaConvert emptyEnv typ + +plTypeWithHypos :: Type -> [String] +plTypeWithHypos (DTyp hypos cat args) = [plTerm (plp cat) (map plp args), plp hypos] + +plFundef :: (CId, (Type, Expr)) -> [String] +plFundef (fun, (_, EEq [])) = [] +plFundef (fun, (_, fundef)) = [plFact "def" [plp fun, plp fundef']] + where fundef' = snd $ alphaConvert emptyEnv fundef + + +---------------------------------------------------------------------- +-- concrete syntax + +plConcrete :: (CId, Concr) -> [String] +plConcrete (cncname, Concr cflags lins opers lincats lindefs + _printnames _paramlincats _parser) = + ["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%", + "%% concrete module: " ++ plp cncname] ++ + clauseHeader "%% cncflag(?Flag, ?Value): flags for concrete syntax" + (map (mod . plpFact2 "cncflag") (Map.assocs cflags)) ++ + clauseHeader "%% lincat(?Cat, ?Linearization type)" + (map (mod . plpFact2 "lincat") (Map.assocs lincats)) ++ + clauseHeader "%% lindef(?Cat, ?Linearization default)" + (map (mod . plpFact2 "lindef") (Map.assocs lindefs)) ++ + clauseHeader "%% lin(?Fun, ?Linearization)" + (map (mod . plpFact2 "lin") (Map.assocs lins)) ++ + clauseHeader "%% oper(?Oper, ?Linearization)" + (map (mod . plpFact2 "oper") (Map.assocs opers)) + where mod clause = plp cncname ++ ": " ++ clause + + +---------------------------------------------------------------------- +-- prolog-printing pgf datatypes + +instance PLPrint Type where + plp (DTyp hypos cat args) | null hypos = result + | otherwise = plOper " -> " (plp hypos) result + where result = plTerm (plp cat) (map plp args) + +instance PLPrint Hypo where + plp (Hyp var typ) = plOper ":" (plp var) (plp typ) + +instance PLPrint Expr where + plp (EVar x) = plp x + plp (EAbs x e) = plOper "^" (plp x) (plp e) + plp (EApp e e') = plOper " * " (plp e) (plp e') + plp (ELit lit) = plp lit + plp (EMeta n) = "Meta_" ++ show n + plp (EEq eqs) = plList [plOper ":" (plp patterns) (plp result) | + Equ patterns result <- eqs] + +instance PLPrint Term where + plp (S terms) = plList (map plp terms) + plp (C n) = show n + plp (K token) = plp token + plp (FV terms) = prCurlyList (map plp terms) + plp (P t1 t2) = plOper "/" (plp t1) (plp t2) + plp (W s trm) = plOper "+" (plp s) (plp trm) + plp (R terms) = plTerm "r" (map plp terms) + plp (F oper) = plTerm "f" [plp oper] + plp (V n) = plTerm "arg" [show n] + plp (TM str) = plTerm "meta" [plp str] + +{-- alternative prolog syntax for PGF terms: +instance PLPrint Term where + plp (R terms) = plTerm "r" [plp terms] + plp (P t1 t2) = plTerm "p" [plp t1, plp t2] + plp (S terms) = plTerm "s" [plp terms] + plp (K tokn) = plTerm "k" [plp tokn] + plp (V n) = plTerm "v" [show n] + plp (C n) = plTerm "c" [show n] + plp (F oper) = plTerm "f" [plp oper] + plp (FV trms) = plTerm "fv" [plp trms] + plp (W s trm) = plTerm "w" [plp s, plp trm] + plp (TM str) = plTerm "tm" [plp str] +--} + +instance PLPrint CId where + plp cid | isLogicalVariable str || + cid == wildCId = plVar str + | otherwise = plAtom str + where str = prCId cid + +instance PLPrint Literal where + plp (LStr s) = plp s + plp (LInt n) = plp (show n) + plp (LFlt f) = plp (show f) + +instance PLPrint Tokn where + plp (KS tokn) = plp tokn + plp (KP strs alts) = plTerm "kp" [plp strs, plList [plOper "/" (plp ss1) (plp ss2) | + Alt ss1 ss2 <- alts]] + +---------------------------------------------------------------------- +-- basic prolog-printing + +class PLPrint a where + plp :: a -> String + plps :: [a] -> String + plps = plList . map plp + +instance PLPrint Char where + plp c = plAtom [c] + plps s = plAtom s + +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] + +plFact :: String -> [String] -> String +plFact fun args = plTerm fun args ++ "." + +plTerm :: String -> [String] -> String +plTerm fun args = plAtom fun ++ prParenth (prTList ", " args) + +plList :: [String] -> String +plList = prBracket . prTList "," + +plOper :: String -> String -> String -> String +plOper op a b = prParenth (a ++ op ++ b) + +plVar :: String -> String +plVar = varPrefix . concatMap changeNonAlphaNum + where varPrefix var@(c:_) | isAsciiUpper c || c=='_' = var + | otherwise = "_" ++ var + changeNonAlphaNum c | isAlphaNumUnderscore c = [c] + | otherwise = "_" ++ show (ord c) ++ "_" + +plAtom :: String -> String +plAtom "" = "''" +plAtom atom@(c:cs) | isAsciiLower c && all isAlphaNumUnderscore cs + || c == '\'' && last cs == '\'' = atom + | otherwise = "'" ++ concatMap changeQuote atom ++ "'" + where changeQuote '\'' = "\\'" + changeQuote c = [c] + +isAlphaNumUnderscore :: Char -> Bool +isAlphaNumUnderscore c = isAlphaNum c || c == '_' + + +---------------------------------------------------------------------- +-- prolog variables + +createLogicalVariable :: Int -> CId +createLogicalVariable n = mkCId (logicalVariablePrefix ++ show n) + +isLogicalVariable :: String -> Bool +isLogicalVariable = isPrefixOf logicalVariablePrefix + +logicalVariablePrefix :: String +logicalVariablePrefix = "X" + +---------------------------------------------------------------------- +-- alpha convert variables to (unique) logical variables +-- * this is needed if we want to translate variables to Prolog variables +-- * used for abstract syntax, not concrete +-- * not (yet?) used for variables bound in pattern equations + +type ConvertEnv = (Int, [(CId,CId)]) + +emptyEnv :: ConvertEnv +emptyEnv = (0, []) + +class AlphaConvert a where + alphaConvert :: ConvertEnv -> a -> (ConvertEnv, a) + +instance AlphaConvert a => AlphaConvert [a] where + alphaConvert env [] = (env, []) + alphaConvert env (a:as) = (env'', a':as') + where (env', a') = alphaConvert env a + (env'', as') = alphaConvert env' as + +instance AlphaConvert Type where + alphaConvert env@(_,subst) (DTyp hypos cat args) + = ((ctr,subst), DTyp hypos' cat args') + where (env', hypos') = alphaConvert env hypos + ((ctr,_), args') = alphaConvert env' args + +instance AlphaConvert Hypo where + alphaConvert env (Hyp x typ) = ((ctr+1,(x,x'):subst), Hyp x' typ') + where ((ctr,subst), typ') = alphaConvert env typ + x' = createLogicalVariable ctr + +instance AlphaConvert Expr where + alphaConvert (ctr,subst) (EAbs x e) = ((ctr',subst), EAbs x' e') + where ((ctr',_), e') = alphaConvert (ctr+1,(x,x'):subst) e + x' = createLogicalVariable ctr + alphaConvert env (EApp e1 e2) = (env'', EApp e1' e2') + where (env', e1') = alphaConvert env e1 + (env'', e2') = alphaConvert env' e2 + alphaConvert env expr@(EVar i) = (env, maybe expr EVar (lookup i (snd env))) + alphaConvert env (EEq eqs) = (env', EEq eqs') + where (env', eqs') = alphaConvert env eqs + alphaConvert env expr = (env, expr) + +-- pattern variables are not alpha converted +-- (but they probably should be...) +instance AlphaConvert Equation where + alphaConvert env@(_,subst) (Equ patterns result) + = ((ctr,subst), Equ patterns' result') + where (env', patterns') = alphaConvert env patterns + ((ctr,_), result') = alphaConvert env' result + +---------------------------------------------------------------------- +-- translate unused variables to wildcards + +wildcardUnusedVars :: Type -> Type +wildcardUnusedVars typ@(DTyp hypos cat args) = DTyp hypos' cat args + where hypos' = [Hyp x' (wildcardUnusedVars typ') | + Hyp x typ' <- hypos, + let x' = if unusedInType x typ then wildCId else x] + + unusedInType x (DTyp hypos _cat args) + = and [unusedInType x typ | Hyp _ typ <- hypos] && + and [unusedInExpr x exp | exp <- args] + + unusedInExpr x (EAbs y e) = unusedInExpr x e + unusedInExpr x (EApp e e') = unusedInExpr x e && unusedInExpr x e' + unusedInExpr x (EVar y) = x/=y + unusedInExpr x (EEq eqs) = and [all (unusedInExpr x) (result:patterns) | + Equ patterns result <- eqs] + unusedInExpr x expr = True diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs index 515f923f2..ed8551957 100644 --- a/src/GF/Infra/Option.hs +++ b/src/GF/Infra/Option.hs @@ -84,6 +84,8 @@ data OutputFormat = FmtPGF | FmtJavaScript | FmtHaskell | FmtHaskell_GADT + | FmtProlog + | FmtProlog_Abs | FmtBNF | FmtSRGS_XML | FmtSRGS_XML_NonRec @@ -393,9 +395,9 @@ optDescr = Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').", Option ['f'] ["output-format"] (ReqArg outFmt "FMT") (unlines ["Output format. FMT can be one of:", - "Multiple concrete: pgf (default), gar, js, ...", + "Multiple concrete: pgf (default), gar, js, prolog, ...", "Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...", - "Abstract only: haskell, ..."]), + "Abstract only: haskell, prolog_abs, ..."]), Option [] ["sisr"] (ReqArg sisrFmt "FMT") (unlines ["Include SISR tags in generated speech recognition grammars.", "FMT can be one of: old, 1.0"]), @@ -444,6 +446,8 @@ outputFormats = ("js", FmtJavaScript), ("haskell", FmtHaskell), ("haskell_gadt", FmtHaskell_GADT), + ("prolog", FmtProlog), + ("prolog_abs", FmtProlog_Abs), ("bnf", FmtBNF), ("srgs_xml", FmtSRGS_XML), ("srgs_xml_nonrec", FmtSRGS_XML_NonRec),