diff --git a/GF.cabal b/GF.cabal index c7db0c18a..bb77c40b7 100644 --- a/GF.cabal +++ b/GF.cabal @@ -575,6 +575,7 @@ library PGF.Parsing.FCFG PGF.Expr PGF.Type + PGF.PMCFG PGF.AbsCompute PGF.Paraphrase PGF.TypeCheck @@ -689,6 +690,7 @@ executable gf PGF.Data PGF.Expr PGF.Type + PGF.PMCFG PGF.Macros PGF.Generate PGF.Linearize diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs index 5674f1107..2a4a8b631 100644 --- a/src/GF/Command/Commands.hs +++ b/src/GF/Command/Commands.hs @@ -17,7 +17,7 @@ import PGF.Data ---- import PGF.Morphology import PGF.VisualizeTree import GF.Compile.Export -import GF.Infra.Option (noOptions) +import GF.Infra.Option (noOptions, readOutputFormat) import GF.Infra.UseIO import GF.Data.ErrM ---- import PGF.Expr (readTree) @@ -376,7 +376,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [ "N.B.2 This command is slightly obsolete: to produce different formats", "the batch compiler gfc is recommended, and has many more options." ], - exec = \opts _ -> return $ fromString $ prGrammar opts, + exec = \opts _ -> prGrammar opts, flags = [ --"cat", ("lang", "select languages for the some options (default all languages)"), @@ -651,15 +651,13 @@ allCommands cod env@(pgf, mos) = Map.fromList [ [] -> (ts, "no trees found") _ -> fromTrees ts - prGrammar opts = case opts of - _ | isOpt "cats" opts -> unwords $ map showType $ categories pgf - _ | isOpt "fullform" opts -> concatMap - (prFullFormLexicon . morpho) $ optLangs opts - _ | isOpt "missing" opts -> - unlines $ [unwords (prCId la:":": map prCId cs) | - la <- optLangs opts, let cs = missingLins pgf la] - _ -> case valStrOpts "printer" "pgf" opts of - v -> concatMap snd $ exportPGF noOptions (read v) pgf + prGrammar opts + | isOpt "cats" opts = return $ fromString $ unwords $ map showType $ categories pgf + | isOpt "fullform" opts = return $ fromString $ concatMap (prFullFormLexicon . morpho) $ optLangs opts + | isOpt "missing" opts = return $ fromString $ unlines $ [unwords (prCId la:":": map prCId cs) | + la <- optLangs opts, let cs = missingLins pgf la] + | otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts) + return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf morphos opts s = [lookupMorpho (morpho la) s | la <- optLangs opts] diff --git a/src/GF/Compile/Export.hs b/src/GF/Compile/Export.hs index 921e48846..051889b59 100644 --- a/src/GF/Compile/Export.hs +++ b/src/GF/Compile/Export.hs @@ -30,6 +30,7 @@ exportPGF :: Options exportPGF opts fmt pgf = case fmt of FmtPGFPretty -> multi "txt" prPGFPretty + FmtPMCFGPretty -> single "pmcfg" prPMCFGPretty FmtJavaScript -> multi "js" pgf2js FmtHaskell -> multi "hs" (grammar2haskell opts name) FmtProlog -> multi "pl" grammar2prolog diff --git a/src/GF/Compile/PGFPretty.hs b/src/GF/Compile/PGFPretty.hs index 7069414fb..b6d8f514b 100644 --- a/src/GF/Compile/PGFPretty.hs +++ b/src/GF/Compile/PGFPretty.hs @@ -1,10 +1,11 @@ -- | Print a part of a PGF grammar on the human-readable format used in -- the paper "PGF: A Portable Run-Time Format for Type-Theoretical Grammars". -module GF.Compile.PGFPretty (prPGFPretty) where +module GF.Compile.PGFPretty (prPGFPretty, prPMCFGPretty) where import PGF.CId import PGF.Data import PGF.Macros +import PGF.PMCFG import GF.Data.Operations @@ -16,6 +17,13 @@ import Text.PrettyPrint.HughesPJ prPGFPretty :: PGF -> String prPGFPretty pgf = render $ prAbs (abstract pgf) $$ prAll (prCnc (abstract pgf)) (concretes pgf) +prPMCFGPretty :: PGF -> CId -> String +prPMCFGPretty pgf lang = render $ + case lookParser pgf lang of + Nothing -> empty + Just pinfo -> text "language" <+> text (prCId lang) $$ ppPMCFG pinfo + + prAbs :: Abstr -> Doc prAbs a = prAll prCat (cats a) $$ prAll prFun (funs a) diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs index 4bc78d2a5..e02130ff3 100644 --- a/src/GF/Infra/Option.hs +++ b/src/GF/Infra/Option.hs @@ -16,7 +16,7 @@ module GF.Infra.Option modifyFlags, helpMessage, -- * Checking specific options - flag, cfgTransform, haskellOption, + flag, cfgTransform, haskellOption, readOutputFormat, isLexicalCat, -- * Setting specific options setOptimization, setCFGTransform, @@ -81,6 +81,7 @@ data Encoding = UTF_8 | ISO_8859_1 | CP_1251 deriving (Eq,Ord) data OutputFormat = FmtPGFPretty + | FmtPMCFGPretty | FmtJavaScript | FmtHaskell | FmtProlog @@ -427,7 +428,8 @@ optDescr = outputFormats :: [(String,OutputFormat)] outputFormats = - [("pgf-pretty", FmtPGFPretty), + [("pgf_pretty", FmtPGFPretty), + ("pmcfg_pretty", FmtPMCFGPretty), ("js", FmtJavaScript), ("haskell", FmtHaskell), ("prolog", FmtProlog), diff --git a/src/PGF/Data.hs b/src/PGF/Data.hs index 047b5ec46..5aba8cdfa 100644 --- a/src/PGF/Data.hs +++ b/src/PGF/Data.hs @@ -1,15 +1,14 @@ -module PGF.Data (module PGF.Data, module PGF.Expr, module PGF.Type) where +module PGF.Data (module PGF.Data, module PGF.Expr, module PGF.Type, module PGF.PMCFG) where import PGF.CId import PGF.Expr hiding (Value, Env) import PGF.Type +import PGF.PMCFG import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.IntMap as IntMap import Data.List -import Data.Array -import Data.Array.Unboxed -- internal datatypes for PGF @@ -54,59 +53,8 @@ data Term = | TM String deriving (Eq,Ord,Show) -data Tokn = - KS String - | KP [String] [Alternative] - deriving (Eq,Ord,Show) - -data Alternative = - Alt [String] [String] - deriving (Eq,Ord,Show) -type FCat = Int -type FIndex = Int -type FPointPos = Int -data FSymbol - = FSymCat {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex - | FSymLit {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex - | FSymTok Tokn - deriving (Eq,Ord,Show) -type Profile = [Int] -data Production - = FApply {-# UNPACK #-} !FunId [FCat] - | FCoerce {-# UNPACK #-} !FCat - | FConst Tree String - deriving (Eq,Ord,Show) -data FFun = FFun CId [Profile] {-# UNPACK #-} !(UArray FIndex SeqId) deriving (Eq,Ord,Show) -type FSeq = Array FPointPos FSymbol -type FunId = Int -type SeqId = Int - -data ParserInfo - = ParserInfo { functions :: Array FunId FFun - , sequences :: Array SeqId FSeq - , productions :: IntMap.IntMap (Set.Set Production) - , startCats :: Map.Map CId [FCat] - , totalCats :: {-# UNPACK #-} !FCat - } - - -fcatString, fcatInt, fcatFloat, fcatVar :: Int -fcatString = (-1) -fcatInt = (-2) -fcatFloat = (-3) -fcatVar = (-4) - - --- print statistics - -statGFCC :: PGF -> String -statGFCC pgf = unlines [ - "Abstract\t" ++ prCId (absname pgf), - "Concretes\t" ++ unwords (map prCId (cncnames pgf)), - "Categories\t" ++ unwords (map prCId (Map.keys (cats (abstract pgf)))) - ] -- merge two GFCCs; fails is differens absnames; priority to second arg diff --git a/src/PGF/PMCFG.hs b/src/PGF/PMCFG.hs new file mode 100644 index 000000000..83bcc0752 --- /dev/null +++ b/src/PGF/PMCFG.hs @@ -0,0 +1,91 @@ +module PGF.PMCFG where + +import PGF.CId +import PGF.Expr + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import Data.Array.IArray +import Data.Array.Unboxed +import Text.PrettyPrint + +type FCat = Int +type FIndex = Int +type FPointPos = Int +data FSymbol + = FSymCat {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex + | FSymLit {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex + | FSymTok Tokn + deriving (Eq,Ord,Show) +type Profile = [Int] +data Production + = FApply {-# UNPACK #-} !FunId [FCat] + | FCoerce {-# UNPACK #-} !FCat + | FConst Tree String + deriving (Eq,Ord,Show) +data FFun = FFun CId [Profile] {-# UNPACK #-} !(UArray FIndex SeqId) deriving (Eq,Ord,Show) +type FSeq = Array FPointPos FSymbol +type FunId = Int +type SeqId = Int + +data Tokn = + KS String + | KP [String] [Alternative] + deriving (Eq,Ord,Show) + +data Alternative = + Alt [String] [String] + deriving (Eq,Ord,Show) + +data ParserInfo + = ParserInfo { functions :: Array FunId FFun + , sequences :: Array SeqId FSeq + , productions :: IntMap.IntMap (Set.Set Production) + , startCats :: Map.Map CId [FCat] + , totalCats :: {-# UNPACK #-} !FCat + } + + +fcatString, fcatInt, fcatFloat, fcatVar :: Int +fcatString = (-1) +fcatInt = (-2) +fcatFloat = (-3) +fcatVar = (-4) + + +ppPMCFG :: ParserInfo -> Doc +ppPMCFG pinfo = + text "productions" $$ + nest 2 (vcat [ppProduction (fcat,prod) | (fcat,set) <- IntMap.toList (productions pinfo), prod <- Set.toList set]) $$ + text "functions" $$ + nest 2 (vcat (map ppFun (assocs (functions pinfo)))) $$ + text "sequences" $$ + nest 2 (vcat (map ppSeq (assocs (sequences pinfo)))) $$ + text "startcats" $$ + nest 2 (vcat (map ppStartCat (Map.toList (startCats pinfo)))) + +ppProduction (fcat,FApply funid args) = + ppFCat fcat <+> text "->" <+> ppFunId funid <> brackets (hcat (punctuate comma (map ppFCat args))) +ppProduction (fcat,FCoerce arg) = + ppFCat fcat <+> text "->" <+> char '_' <> brackets (ppFCat arg) +ppProduction (fcat,FConst _ s) = + ppFCat fcat <+> text "->" <+> text (show s) + +ppFun (funid,FFun fun _ arr) = + ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) + +ppSeq (seqid,seq) = + ppSeqId seqid <+> text ":=" <+> parens (hsep (map ppSymbol (elems seq))) + +ppStartCat (id,fcats) = + text (prCId id) <+> text ":=" <+> brackets (hcat (punctuate comma (map ppFCat fcats))) + +ppSymbol (FSymCat d r) = char '<' <> int d <> comma <> int r <> char '>' +ppSymbol (FSymLit d r) = char '<' <> int d <> comma <> int r <> char '>' +ppSymbol (FSymTok t) = text (show t) + + +ppFCat fcat = char 'C' <> int fcat +ppFunId funid = char 'F' <> int funid +ppSeqId seqid = char 'S' <> int seqid