summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/GF/Command/Commands.hs20
-rw-r--r--src/GF/Compile/Export.hs1
-rw-r--r--src/GF/Compile/PGFPretty.hs10
-rw-r--r--src/GF/Infra/Option.hs6
-rw-r--r--src/PGF/Data.hs56
-rw-r--r--src/PGF/PMCFG.hs91
6 files changed, 116 insertions, 68 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 08:32:14 +0000