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

PMCFG pretty printer

Browse Source
This commit is contained in:
krasimir
2009-02-07 23:31:22 +00:00
parent 14c13cb080
commit 5c2ce87cde
7 changed files with 118 additions and 68 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
GF.cabal
View File

@@ -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

20
src/GF/Command/Commands.hs
View File

@@ -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]

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

@@ -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

10
src/GF/Compile/PGFPretty.hs
View File

@@ -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)

6
src/GF/Infra/Option.hs
View File

@@ -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),

56
src/PGF/Data.hs
View File

@@ -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

91
src/PGF/PMCFG.hs Normal file
View File

@@ -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