msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

now the datatype Tree is only internal. All API functions are working with Expr directly. Commands gt, gr, p and rf filter out the output via the typechecker

Browse Source
This commit is contained in:
krasimir
2009-09-08 08:40:28 +00:00
parent 4f878c1f91
commit be3dc0ef9e
23 changed files with 272 additions and 322 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
GF.cabal
View File

@@ -43,9 +43,9 @@ library
PGF.Parsing.FCFG.Utilities PGF.Parsing.FCFG.Utilities
PGF.Parsing.FCFG.Active PGF.Parsing.FCFG.Active
PGF.Parsing.FCFG.Incremental PGF.Parsing.FCFG.Incremental
PGF.Parsing.FCFG
PGF.Expr PGF.Expr
PGF.Type PGF.Type
PGF.Tree
PGF.PMCFG PGF.PMCFG
PGF.Paraphrase PGF.Paraphrase
PGF.TypeCheck PGF.TypeCheck
@@ -160,6 +160,7 @@ executable gf
PGF.Data PGF.Data
PGF.Expr PGF.Expr
PGF.Type PGF.Type
PGF.Tree
PGF.PMCFG PGF.PMCFG
PGF.Macros PGF.Macros
PGF.Generate PGF.Generate
@@ -167,7 +168,6 @@ executable gf
PGF.BuildParser PGF.BuildParser
PGF.Parsing.FCFG.Utilities PGF.Parsing.FCFG.Utilities
PGF.Parsing.FCFG.Active PGF.Parsing.FCFG.Active
PGF.Parsing.FCFG
PGF.Binary PGF.Binary
PGF.Paraphrase PGF.Paraphrase
PGF.TypeCheck PGF.TypeCheck

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

@@ -20,7 +20,6 @@ import GF.Compile.Export
import GF.Infra.Option (noOptions, readOutputFormat, Encoding(..)) import GF.Infra.Option (noOptions, readOutputFormat, Encoding(..))
import GF.Infra.UseIO import GF.Infra.UseIO
import GF.Data.ErrM ---- import GF.Data.ErrM ----
import PGF.Expr (readTree)
import GF.Command.Abstract import GF.Command.Abstract
import GF.Command.Messages import GF.Command.Messages
import GF.Text.Lexing import GF.Text.Lexing
@@ -140,8 +139,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
"flag -format." "flag -format."
], ],
exec = \opts es -> do exec = \opts es -> do
let ts = toTrees es let grph = if null es then [] else alignLinearize pgf (head es)
grph = if null ts then [] else alignLinearize pgf (head ts)
if isFlag "view" opts || isFlag "format" opts then do if isFlag "view" opts || isFlag "format" opts then do
let file s = "_grph." ++ s let file s = "_grph." ++ s
let view = optViewGraph opts ++ " " let view = optViewGraph opts ++ " "
@@ -241,7 +239,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
exec = \opts _ -> do exec = \opts _ -> do
let pgfr = optRestricted opts let pgfr = optRestricted opts
ts <- generateRandom pgfr (optType opts) ts <- generateRandom pgfr (optType opts)
return $ fromTrees $ take (optNum opts) ts returnFromExprs $ take (optNum opts) ts
}), }),
("gt", emptyCommandInfo { ("gt", emptyCommandInfo {
longname = "generate_trees", longname = "generate_trees",
@@ -262,7 +260,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
let pgfr = optRestricted opts let pgfr = optRestricted opts
let dp = return $ valIntOpts "depth" 4 opts let dp = return $ valIntOpts "depth" 4 opts
let ts = generateAllDepth pgfr (optType opts) dp let ts = generateAllDepth pgfr (optType opts) dp
returnFromTrees $ take (optNumInf opts) ts returnFromExprs $ take (optNumInf opts) ts
}), }),
("h", emptyCommandInfo { ("h", emptyCommandInfo {
longname = "help", longname = "help",
@@ -329,7 +327,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
"gr -lang=LangHin -cat=Cl | l -table -to_devanagari -to_utf8 -- hindi table", "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -to_utf8 -- hindi table",
"l -unlexer=\"LangSwe=to_utf8 LangHin=to_devanagari,to_utf8\" -- different lexers" "l -unlexer=\"LangSwe=to_utf8 LangHin=to_devanagari,to_utf8\" -- different lexers"
], ],
exec = \opts -> return . fromStrings . map (optLin opts) . toTrees, exec = \opts -> return . fromStrings . map (optLin opts),
options = [ options = [
("all","show all forms and variants"), ("all","show all forms and variants"),
("bracket","show tree structure with brackets and paths to nodes"), ("bracket","show tree structure with brackets and paths to nodes"),
@@ -381,7 +379,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
"The default start category can be overridden by the -cat flag.", "The default start category can be overridden by the -cat flag.",
"See also the ps command for lexing and character encoding." "See also the ps command for lexing and character encoding."
], ],
exec = \opts -> returnFromTrees . concatMap (par opts) . toStrings, exec = \opts -> returnFromExprs . concatMap (par opts) . toStrings,
flags = [ flags = [
("cat","target category of parsing"), ("cat","target category of parsing"),
("lang","the languages of parsing (comma-separated, no spaces)") ("lang","the languages of parsing (comma-separated, no spaces)")
@@ -490,13 +488,13 @@ allCommands cod env@(pgf, mos) = Map.fromList [
exec = \opts _ -> do exec = \opts _ -> do
let file = valStrOpts "file" "_gftmp" opts let file = valStrOpts "file" "_gftmp" opts
s <- readFile file s <- readFile file
return $ case opts of case opts of
_ | isOpt "lines" opts && isOpt "tree" opts -> _ | isOpt "lines" opts && isOpt "tree" opts ->
fromTrees [t | l <- lines s, Just t <- [readTree l]] returnFromExprs [e | l <- lines s, Just e0 <- [readExpr l], Right (e,t) <- [inferExpr pgf e0]]
_ | isOpt "tree" opts -> _ | isOpt "tree" opts ->
fromTrees [t | Just t <- [readTree s]] returnFromExprs [e | Just e0 <- [readExpr s], Right (e,t) <- [inferExpr pgf e0]]
_ | isOpt "lines" opts -> fromStrings $ lines s _ | isOpt "lines" opts -> return (fromStrings $ lines s)
_ -> fromString s, _ -> return (fromString s),
flags = [("file","the input file name")] flags = [("file","the input file name")]
}), }),
("tq", emptyCommandInfo { ("tq", emptyCommandInfo {
@@ -565,10 +563,9 @@ allCommands cod env@(pgf, mos) = Map.fromList [
"flag -format." "flag -format."
], ],
exec = \opts es -> do exec = \opts es -> do
let ts = toTrees es let funs = not (isOpt "nofun" opts)
funs = not (isOpt "nofun" opts)
let cats = not (isOpt "nocat" opts) let cats = not (isOpt "nocat" opts)
let grph = visualizeTrees pgf (funs,cats) ts -- True=digraph let grph = visualizeTrees pgf (funs,cats) es -- True=digraph
if isFlag "view" opts || isFlag "format" opts then do if isFlag "view" opts || isFlag "format" opts then do
let file s = "_grph." ++ s let file s = "_grph." ++ s
let view = optViewGraph opts ++ " " let view = optViewGraph opts ++ " "
@@ -644,26 +641,24 @@ allCommands cod env@(pgf, mos) = Map.fromList [
] ]
where where
enc = encodeUnicode cod enc = encodeUnicode cod
lin opts t = unlines [linearize pgf lang t | lang <- optLangs opts]
par opts s = concat [parse pgf lang (optType opts) s | lang <- optLangs opts, canParse pgf lang] par opts s = concat [parse pgf lang (optType opts) s | lang <- optLangs opts, canParse pgf lang]
void = ([],[]) void = ([],[])
optLin opts t = case opts of optLin opts t = unlines $
_ | isOpt "treebank" opts -> treebank opts t case opts of
_ -> unlines [linear opts lang t | lang <- optLangs opts] _ | isOpt "treebank" opts -> (prCId (abstractName pgf) ++ ": " ++ showExpr [] t) :
[prCId lang ++ ": " ++ linear opts lang t | lang <- optLangs opts]
_ -> [linear opts lang t | lang <- optLangs opts]
linear :: [Option] -> CId -> Expr -> String
linear opts lang = let unl = unlex opts lang in case opts of linear opts lang = let unl = unlex opts lang in case opts of
_ | isOpt "all" opts -> allLinearize unl pgf lang _ | isOpt "all" opts -> allLinearize unl pgf lang
_ | isOpt "table" opts -> tableLinearize unl pgf lang _ | isOpt "table" opts -> tableLinearize unl pgf lang
_ | isOpt "term" opts -> termLinearize pgf lang _ | isOpt "term" opts -> termLinearize pgf lang
_ | isOpt "record" opts -> recordLinearize pgf lang _ | isOpt "record" opts -> recordLinearize pgf lang
_ | isOpt "bracket" opts -> markLinearize pgf lang _ | isOpt "bracket" opts -> markLinearize pgf lang
_ -> unl . linearize pgf lang _ -> unl . linearize pgf lang
treebank opts t = unlines $
(prCId (abstractName pgf) ++ ": " ++ showTree t) :
[prCId lang ++ ": " ++ linear opts lang t | lang <- optLangs opts]
unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ---- unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ----
@@ -705,21 +700,16 @@ allCommands cod env@(pgf, mos) = Map.fromList [
optViewGraph opts = valStrOpts "view" "open" opts optViewGraph opts = valStrOpts "view" "open" opts
optNum opts = valIntOpts "number" 1 opts optNum opts = valIntOpts "number" 1 opts
optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9 optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9
fromTrees ts = (map tree2expr ts,unlines (map showTree ts)) fromExprs es = (es,unlines (map (showExpr []) es))
fromStrings ss = (map (ELit . LStr) ss, unlines ss) fromStrings ss = (map (ELit . LStr) ss, unlines ss)
fromString s = ([ELit (LStr s)], s) fromString s = ([ELit (LStr s)], s)
toTrees = map expr2tree
toStrings = map showAsString toStrings = map showAsString
toString = unwords . toStrings toString = unwords . toStrings
returnFromTrees ts = return $ case ts of
[] -> ([], "no trees found")
_ -> fromTrees ts
returnFromExprs es = return $ case es of returnFromExprs es = return $ case es of
[] -> ([], "no trees found") [] -> ([], "no trees found")
_ -> (es,unlines (map (showExpr []) es)) _ -> fromExprs es
prGrammar opts prGrammar opts
| isOpt "cats" opts = return $ fromString $ unwords $ map (showType []) $ categories pgf | isOpt "cats" opts = return $ fromString $ unwords $ map (showType []) $ categories pgf

1
src/GF/Command/Parse.hs
View File

@@ -2,7 +2,6 @@ module GF.Command.Parse(readCommandLine, pCommand) where
import PGF.CId import PGF.CId
import PGF.Expr import PGF.Expr
import PGF.Data(Tree)
import GF.Command.Abstract import GF.Command.Abstract
import Data.Char import Data.Char

2
src/GF/Command/TreeOperations.hs
View File

@@ -18,7 +18,7 @@ allTreeOps pgf = [
("compute",("compute by using semantic definitions (def)", ("compute",("compute by using semantic definitions (def)",
map (compute pgf))), map (compute pgf))),
("paraphrase",("paraphrase by using semantic definitions (def)", ("paraphrase",("paraphrase by using semantic definitions (def)",
map tree2expr . nub . concatMap (paraphrase pgf . expr2tree))), nub . concatMap (paraphrase pgf))),
("smallest",("sort trees from smallest to largest, in number of nodes", ("smallest",("sort trees from smallest to largest, in number of nodes",
smallest)) smallest))
] ]

1
src/GF/Quiz.hs
View File

@@ -20,7 +20,6 @@ module GF.Quiz (
import PGF import PGF
import PGF.ShowLinearize import PGF.ShowLinearize
import GF.Data.Operations import GF.Data.Operations
import GF.Infra.UseIO import GF.Infra.UseIO
import GF.Infra.Option import GF.Infra.Option

1
src/GFI.hs
View File

@@ -21,7 +21,6 @@ import GF.Compile.Coding
import PGF import PGF
import PGF.Data import PGF.Data
import PGF.Macros import PGF.Macros
import PGF.Expr (readTree)
import Data.Char import Data.Char
import Data.Maybe import Data.Maybe

75
src/PGF.hs
View File

@@ -33,13 +33,9 @@ module PGF(
-- * Expressions -- * Expressions
-- ** Identifiers -- ** Identifiers
CId, mkCId, prCId, wildCId, CId, mkCId, prCId, wildCId,
-- ** Tree
Tree(..), Literal(..),
showTree, readTree,
-- ** Expr -- ** Expr
Expr(..), Equation(..), Literal(..), Expr(..),
showExpr, readExpr, showExpr, readExpr,
-- * Operations -- * Operations
@@ -51,7 +47,7 @@ module PGF(
parse, canParse, parseAllLang, parseAll, parse, canParse, parseAllLang, parseAll,
-- ** Evaluation -- ** Evaluation
tree2expr, expr2tree, PGF.compute, paraphrase, PGF.compute, paraphrase,
-- ** Type Checking -- ** Type Checking
checkType, checkExpr, inferExpr, checkType, checkExpr, inferExpr,
@@ -60,7 +56,7 @@ module PGF(
-- ** Word Completion (Incremental Parsing) -- ** Word Completion (Incremental Parsing)
complete, complete,
Incremental.ParseState, Incremental.ParseState,
initState, Incremental.nextState, Incremental.getCompletions, extractExps, Incremental.initState, Incremental.nextState, Incremental.getCompletions, Incremental.extractExps,
-- ** Generation -- ** Generation
generateRandom, generateAll, generateAllDepth generateRandom, generateAll, generateAllDepth
@@ -74,12 +70,11 @@ import PGF.Paraphrase
import PGF.Macros import PGF.Macros
import PGF.Data hiding (functions) import PGF.Data hiding (functions)
import PGF.Binary import PGF.Binary
import PGF.Parsing.FCFG import qualified PGF.Parsing.FCFG.Active as Active
import qualified PGF.Parsing.FCFG.Incremental as Incremental import qualified PGF.Parsing.FCFG.Incremental as Incremental
import qualified GF.Compile.GeneratePMCFG as PMCFG import qualified GF.Compile.GeneratePMCFG as PMCFG
import GF.Infra.Option import GF.Infra.Option
import GF.Data.ErrM
import GF.Data.Utilities (replace) import GF.Data.Utilities (replace)
import Data.Char import Data.Char
@@ -94,19 +89,6 @@ import Control.Monad
-- Interface -- Interface
--------------------------------------------------- ---------------------------------------------------
-- | This is just a 'CId' with the language name.
-- A language name is the identifier that you write in the
-- top concrete or abstract module in GF after the
-- concrete/abstract keyword. Example:
--
-- > abstract Lang = ...
-- > concrete LangEng of Lang = ...
type Language = CId
readLanguage :: String -> Maybe Language
showLanguage :: Language -> String
-- | Reads file in Portable Grammar Format and produces -- | Reads file in Portable Grammar Format and produces
-- 'PGF' structure. The file is usually produced with: -- 'PGF' structure. The file is usually produced with:
-- --
@@ -114,7 +96,7 @@ showLanguage :: Language -> String
readPGF :: FilePath -> IO PGF readPGF :: FilePath -> IO PGF
-- | Linearizes given expression as string in the language -- | Linearizes given expression as string in the language
linearize :: PGF -> Language -> Tree -> String linearize :: PGF -> Language -> Expr -> String
-- | Tries to parse the given string in the specified language -- | Tries to parse the given string in the specified language
-- and to produce abstract syntax expression. An empty -- and to produce abstract syntax expression. An empty
@@ -122,25 +104,25 @@ linearize :: PGF -> Language -> Tree -> String
-- contain more than one element if the grammar is ambiguous. -- contain more than one element if the grammar is ambiguous.
-- Throws an exception if the given language cannot be used -- Throws an exception if the given language cannot be used
-- for parsing, see 'canParse'. -- for parsing, see 'canParse'.
parse :: PGF -> Language -> Type -> String -> [Tree] parse :: PGF -> Language -> Type -> String -> [Expr]
-- | Checks whether the given language can be used for parsing. -- | Checks whether the given language can be used for parsing.
canParse :: PGF -> Language -> Bool canParse :: PGF -> Language -> Bool
-- | The same as 'linearizeAllLang' but does not return -- | The same as 'linearizeAllLang' but does not return
-- the language. -- the language.
linearizeAll :: PGF -> Tree -> [String] linearizeAll :: PGF -> Expr -> [String]
-- | Linearizes given expression as string in all languages -- | Linearizes given expression as string in all languages
-- available in the grammar. -- available in the grammar.
linearizeAllLang :: PGF -> Tree -> [(Language,String)] linearizeAllLang :: PGF -> Expr -> [(Language,String)]
-- | Show the printname of a type -- | Show the printname of a type
showPrintName :: PGF -> Language -> Type -> String showPrintName :: PGF -> Language -> Type -> String
-- | The same as 'parseAllLang' but does not return -- | The same as 'parseAllLang' but does not return
-- the language. -- the language.
parseAll :: PGF -> Type -> String -> [[Tree]] parseAll :: PGF -> Type -> String -> [[Expr]]
-- | Tries to parse the given string with all available languages. -- | Tries to parse the given string with all available languages.
-- Languages which cannot be used for parsing (see 'canParse') -- Languages which cannot be used for parsing (see 'canParse')
@@ -150,31 +132,21 @@ parseAll :: PGF -> Type -> String -> [[Tree]]
-- (this is a list, since grammars can be ambiguous). -- (this is a list, since grammars can be ambiguous).
-- Only those languages -- Only those languages
-- for which at least one parsing is possible are listed. -- for which at least one parsing is possible are listed.
parseAllLang :: PGF -> Type -> String -> [(Language,[Tree])] parseAllLang :: PGF -> Type -> String -> [(Language,[Expr])]
-- | Creates an initial parsing state for a given language and
-- startup category.
initState :: PGF -> Language -> Type -> Incremental.ParseState
-- | This function extracts the list of all completed parse trees
-- that spans the whole input consumed so far. The trees are also
-- limited by the category specified, which is usually
-- the same as the startup category.
extractExps :: Incremental.ParseState -> Type -> [Tree]
-- | The same as 'generateAllDepth' but does not limit -- | The same as 'generateAllDepth' but does not limit
-- the depth in the generation. -- the depth in the generation.
generateAll :: PGF -> Type -> [Tree] generateAll :: PGF -> Type -> [Expr]
-- | Generates an infinite list of random abstract syntax expressions. -- | Generates an infinite list of random abstract syntax expressions.
-- This is usefull for tree bank generation which after that can be used -- This is usefull for tree bank generation which after that can be used
-- for grammar testing. -- for grammar testing.
generateRandom :: PGF -> Type -> IO [Tree] generateRandom :: PGF -> Type -> IO [Expr]
-- | Generates an exhaustive possibly infinite list of -- | Generates an exhaustive possibly infinite list of
-- abstract syntax expressions. A depth can be specified -- abstract syntax expressions. A depth can be specified
-- to limit the search space. -- to limit the search space.
generateAllDepth :: PGF -> Type -> Maybe Int -> [Tree] generateAllDepth :: PGF -> Type -> Maybe Int -> [Expr]
-- | List of all languages available in the given grammar. -- | List of all languages available in the given grammar.
languages :: PGF -> [Language] languages :: PGF -> [Language]
@@ -221,10 +193,6 @@ complete :: PGF -> Language -> Type -> String
-- Implementation -- Implementation
--------------------------------------------------- ---------------------------------------------------
readLanguage = readCId
showLanguage = prCId
readPGF f = decodeFile f >>= addParsers readPGF f = decodeFile f >>= addParsers
-- Adds parsers for all concretes that don't have a parser and that have parser=ondemand. -- Adds parsers for all concretes that don't have a parser and that have parser=ondemand.
@@ -243,10 +211,8 @@ parse pgf lang typ s =
case Map.lookup lang (concretes pgf) of case Map.lookup lang (concretes pgf) of
Just cnc -> case parser cnc of Just cnc -> case parser cnc of
Just pinfo -> if Map.lookup (mkCId "erasing") (cflags cnc) == Just "on" Just pinfo -> if Map.lookup (mkCId "erasing") (cflags cnc) == Just "on"
then Incremental.parse pinfo typ (words s) then Incremental.parse pgf lang typ (words s)
else case parseFCFG "topdown" pinfo typ (words s) of else Active.parse "t" pinfo typ (words s)
Ok x -> x
Bad s -> error s
Nothing -> error ("No parser built for language: " ++ prCId lang) Nothing -> error ("No parser built for language: " ++ prCId lang)
Nothing -> error ("Unknown language: " ++ prCId lang) Nothing -> error ("Unknown language: " ++ prCId lang)
@@ -263,13 +229,6 @@ parseAll mgr typ = map snd . parseAllLang mgr typ
parseAllLang mgr typ s = parseAllLang mgr typ s =
[(lang,ts) | lang <- languages mgr, canParse mgr lang, let ts = parse mgr lang typ s, not (null ts)] [(lang,ts) | lang <- languages mgr, canParse mgr lang, let ts = parse mgr lang typ s, not (null ts)]
initState pgf lang typ =
case lookParser pgf lang of
Just pinfo -> Incremental.initState pinfo typ
_ -> error ("Unknown language: " ++ prCId lang)
extractExps state typ = Incremental.extractExps state typ
generateRandom pgf cat = do generateRandom pgf cat = do
gen <- newStdGen gen <- newStdGen
return $ genRandom gen pgf cat return $ genRandom gen pgf cat
@@ -297,11 +256,11 @@ functionType pgf fun =
complete pgf from typ input = complete pgf from typ input =
let (ws,prefix) = tokensAndPrefix input let (ws,prefix) = tokensAndPrefix input
state0 = initState pgf from typ state0 = Incremental.initState pgf from typ
in case foldM Incremental.nextState state0 ws of in case foldM Incremental.nextState state0 ws of
Nothing -> [] Nothing -> []
Just state -> Just state ->
(if null prefix && not (null (extractExps state typ)) then [unwords ws ++ " "] else []) (if null prefix && not (null (Incremental.extractExps state typ)) then [unwords ws ++ " "] else [])
++ [unwords (ws++[c]) ++ " " | c <- Map.keys (Incremental.getCompletions state prefix)] ++ [unwords (ws++[c]) ++ " " | c <- Map.keys (Incremental.getCompletions state prefix)]
where where
tokensAndPrefix :: String -> ([String],String) tokensAndPrefix :: String -> ([String],String)

15
src/PGF/Data.hs
View File

@@ -78,3 +78,18 @@ emptyPGF = PGF {
abstract = error "empty grammar, no abstract", abstract = error "empty grammar, no abstract",
concretes = Map.empty concretes = Map.empty
} }
-- | This is just a 'CId' with the language name.
-- A language name is the identifier that you write in the
-- top concrete or abstract module in GF after the
-- concrete/abstract keyword. Example:
--
-- > abstract Lang = ...
-- > concrete LangEng of Lang = ...
type Language = CId
readLanguage :: String -> Maybe Language
readLanguage = readCId
showLanguage :: Language -> String
showLanguage = prCId

102
src/PGF/Expr.hs
View File

@@ -1,10 +1,7 @@
module PGF.Expr(Tree(..), Literal(..), module PGF.Expr(Expr(..), Literal(..), Patt(..), Equation(..),
readTree, showTree, pTree, ppTree,
Expr(..), Patt(..), Equation(..),
readExpr, showExpr, pExpr, ppExpr, ppPatt, readExpr, showExpr, pExpr, ppExpr, ppPatt,
tree2expr, expr2tree, normalForm, normalForm,
-- needed in the typechecker -- needed in the typechecker
Value(..), Env, Funs, eval, apply, Value(..), Env, Funs, eval, apply,
@@ -12,7 +9,7 @@ module PGF.Expr(Tree(..), Literal(..),
MetaId, MetaId,
-- helpers -- helpers
pStr,pFactor,freshName,ppMeta pMeta,pStr,pFactor,pLit,freshName,ppMeta,ppLit,ppParens
) where ) where
import PGF.CId import PGF.CId
@@ -34,18 +31,6 @@ data Literal =
type MetaId = Int type MetaId = Int
-- | The tree is an evaluated expression in the abstract syntax
-- of the grammar. The type is especially restricted to not
-- allow unapplied lambda abstractions. The tree is used directly
-- from the linearizer and is produced directly from the parser.
data Tree =
Abs [CId] Tree -- ^ lambda abstraction. The list of variables is non-empty
| Var CId -- ^ variable
| Fun CId [Tree] -- ^ function application
| Lit Literal -- ^ literal
| Meta {-# UNPACK #-} !MetaId -- ^ meta variable
deriving (Eq, Ord)
-- | An expression represents a potentially unevaluated expression -- | An expression represents a potentially unevaluated expression
-- in the abstract syntax of the grammar. -- in the abstract syntax of the grammar.
data Expr = data Expr =
@@ -74,22 +59,6 @@ data Equation =
Equ [Patt] Expr Equ [Patt] Expr
deriving (Eq,Ord) deriving (Eq,Ord)
-- | parses 'String' as an expression
readTree :: String -> Maybe Tree
readTree s = case [x | (x,cs) <- RP.readP_to_S (pTree False) s, all isSpace cs] of
[x] -> Just x
_ -> Nothing
-- | renders expression as 'String'
showTree :: Tree -> String
showTree = PP.render . ppTree 0
instance Show Tree where
showsPrec i x = showString (PP.render (ppTree i x))
instance Read Tree where
readsPrec _ = RP.readP_to_S (pTree False)
-- | parses 'String' as an expression -- | parses 'String' as an expression
readExpr :: String -> Maybe Expr readExpr :: String -> Maybe Expr
readExpr s = case [x | (x,cs) <- RP.readP_to_S pExpr s, all isSpace cs] of readExpr s = case [x | (x,cs) <- RP.readP_to_S pExpr s, all isSpace cs] of
@@ -111,20 +80,6 @@ instance Read Expr where
-- Parsing -- Parsing
----------------------------------------------------- -----------------------------------------------------
pTrees :: RP.ReadP [Tree]
pTrees = liftM2 (:) (pTree True) pTrees RP.<++ (RP.skipSpaces >> return [])
pTree :: Bool -> RP.ReadP Tree
pTree isNested = RP.skipSpaces >> (pParen RP.<++ pAbs RP.<++ pApp RP.<++ fmap Lit pLit RP.<++ fmap Meta pMeta)
where
pParen = RP.between (RP.char '(') (RP.char ')') (pTree False)
pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") (RP.sepBy1 (RP.skipSpaces >> pCId) (RP.skipSpaces >> RP.char ','))
t <- pTree False
return (Abs xs t)
pApp = do f <- pCId
ts <- (if isNested then return [] else pTrees)
return (Fun f ts)
pExpr :: RP.ReadP Expr pExpr :: RP.ReadP Expr
pExpr = pExpr0 >>= optTyped pExpr = pExpr0 >>= optTyped
where where
@@ -169,17 +124,6 @@ pStr = RP.char '"' >> (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"'))
-- Printing -- Printing
----------------------------------------------------- -----------------------------------------------------
ppTree d (Abs xs t) = ppParens (d > 0) (PP.char '\\' PP.<>
PP.hsep (PP.punctuate PP.comma (List.map (PP.text . prCId) xs)) PP.<+>
PP.text "->" PP.<+>
ppTree 0 t)
ppTree d (Fun f []) = PP.text (prCId f)
ppTree d (Fun f ts) = ppParens (d > 0) (PP.text (prCId f) PP.<+> PP.hsep (List.map (ppTree 1) ts))
ppTree d (Lit l) = ppLit l
ppTree d (Meta n) = ppMeta n
ppTree d (Var id) = PP.text (prCId id)
ppExpr :: Int -> [CId] -> Expr -> PP.Doc ppExpr :: Int -> [CId] -> Expr -> PP.Doc
ppExpr d scope (EAbs x e) = let (xs,e1) = getVars [x] e ppExpr d scope (EAbs x e) = let (xs,e1) = getVars [x] e
in ppParens (d > 1) (PP.char '\\' PP.<> in ppParens (d > 1) (PP.char '\\' PP.<>
@@ -221,46 +165,6 @@ freshName x xs = loop 1 x
| elem y xs = loop (i+1) (mkCId (show x++"'"++show i)) | elem y xs = loop (i+1) (mkCId (show x++"'"++show i))
| otherwise = y | otherwise = y
-----------------------------------------------------
-- Conversion Expr <-> Tree
-----------------------------------------------------
-- | Converts a tree to expression. The conversion
-- is always total, every tree is a valid expression.
tree2expr :: Tree -> Expr
tree2expr = tree2expr []
where
tree2expr ys (Fun x ts) = foldl EApp (EFun x) (List.map (tree2expr ys) ts)
tree2expr ys (Lit l) = ELit l
tree2expr ys (Meta n) = EMeta n
tree2expr ys (Abs xs t) = foldr EAbs (tree2expr (reverse xs++ys) t) xs
tree2expr ys (Var x) = case List.lookup x (zip ys [0..]) of
Just i -> EVar i
Nothing -> error "unknown variable"
-- | Converts an expression to tree. The conversion is only partial.
-- Variables and meta variables of function type and beta redexes are not allowed.
expr2tree :: Expr -> Tree
expr2tree e = abs [] [] e
where
abs ys xs (EAbs x e) = abs ys (x:xs) e
abs ys xs (ETyped e _) = abs ys xs e
abs ys xs e = case xs of
[] -> app ys [] e
xs -> Abs (reverse xs) (app (xs++ys) [] e)
app xs as (EApp e1 e2) = app xs ((abs xs [] e2) : as) e1
app xs as (ELit l)
| List.null as = Lit l
| otherwise = error "literal of function type encountered"
app xs as (EMeta n)
| List.null as = Meta n
| otherwise = error "meta variables of function type are not allowed in trees"
app xs as (EAbs x e) = error "beta redexes are not allowed in trees"
app xs as (EVar i) = Var (xs !! i)
app xs as (EFun f) = Fun f as
app xs as (ETyped e _) = app xs as e
----------------------------------------------------- -----------------------------------------------------
-- Computation -- Computation

4
src/PGF/Expr.hs-boot
View File

@@ -14,4 +14,6 @@ pFactor :: RP.ReadP Expr
ppExpr :: Int -> [CId] -> Expr -> PP.Doc ppExpr :: Int -> [CId] -> Expr -> PP.Doc
freshName :: CId -> [CId] -> CId freshName :: CId -> [CId] -> CId
ppParens :: Bool -> PP.Doc -> PP.Doc

45
src/PGF/Generate.hs
View File

@@ -3,30 +3,37 @@ module PGF.Generate where
import PGF.CId import PGF.CId
import PGF.Data import PGF.Data
import PGF.Macros import PGF.Macros
import PGF.TypeCheck
import qualified Data.Map as M import qualified Data.Map as M
import System.Random import System.Random
-- generate an infinite list of trees exhaustively -- generate an infinite list of trees exhaustively
generate :: PGF -> Type -> Maybe Int -> [Tree] generate :: PGF -> Type -> Maybe Int -> [Expr]
generate pgf (DTyp _ cat _) dp = concatMap (\i -> gener i cat) depths generate pgf ty@(DTyp _ cat _) dp = filter (\e -> case checkExpr pgf e ty of
Left _ -> False
Right _ -> True )
(concatMap (\i -> gener i cat) depths)
where where
gener 0 c = [Fun f [] | (f, ([],_)) <- fns c] gener 0 c = [EFun f | (f, ([],_)) <- fns c]
gener i c = [ gener i c = [
tr | tr |
(f, (cs,_)) <- fns c, (f, (cs,_)) <- fns c,
let alts = map (gener (i-1)) cs, let alts = map (gener (i-1)) cs,
ts <- combinations alts, ts <- combinations alts,
let tr = Fun f ts, let tr = foldl EApp (EFun f) ts,
depth tr >= i depth tr >= i
] ]
fns c = [(f,catSkeleton ty) | (f,ty) <- functionsToCat pgf c] fns c = [(f,catSkeleton ty) | (f,ty) <- functionsToCat pgf c]
depths = maybe [0 ..] (\d -> [0..d]) dp depths = maybe [0 ..] (\d -> [0..d]) dp
-- generate an infinite list of trees randomly -- generate an infinite list of trees randomly
genRandom :: StdGen -> PGF -> Type -> [Tree] genRandom :: StdGen -> PGF -> Type -> [Expr]
genRandom gen pgf (DTyp _ cat _) = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where genRandom gen pgf ty@(DTyp _ cat _) = filter (\e -> case checkExpr pgf e ty of
Left _ -> False
Right _ -> True )
(genTrees (randomRs (0.0, 1.0 :: Double) gen) cat)
where
timeout = 47 -- give up timeout = 47 -- give up
genTrees ds0 cat = genTrees ds0 cat =
@@ -36,17 +43,17 @@ genRandom gen pgf (DTyp _ cat _) = genTrees (randomRs (0.0, 1.0 :: Double) gen)
(genTrees ds2 cat) -- else (drop k ds) (genTrees ds2 cat) -- else (drop k ds)
genTree rs = gett rs where genTree rs = gett rs where
gett ds cid | cid == cidString = (Lit (LStr "foo"), 1) gett ds cid | cid == cidString = (ELit (LStr "foo"), 1)
gett ds cid | cid == cidInt = (Lit (LInt 12345), 1) gett ds cid | cid == cidInt = (ELit (LInt 12345), 1)
gett ds cid | cid == cidFloat = (Lit (LFlt 12345), 1) gett ds cid | cid == cidFloat = (ELit (LFlt 12345), 1)
gett [] _ = (Lit (LStr "TIMEOUT"), 1) ---- gett [] _ = (ELit (LStr "TIMEOUT"), 1) ----
gett ds cat = case fns cat of gett ds cat = case fns cat of
[] -> (Meta 0,1) [] -> (EMeta 0,1)
fs -> let fs -> let
d:ds2 = ds d:ds2 = ds
(f,args) = getf d fs (f,args) = getf d fs
(ts,k) = getts ds2 args (ts,k) = getts ds2 args
in (Fun f ts, k+1) in (foldl EApp (EFun f) ts, k+1)
getf d fs = let lg = (length fs) in getf d fs = let lg = (length fs) in
fs !! (floor (d * fromIntegral lg)) fs !! (floor (d * fromIntegral lg))
getts ds cats = case cats of getts ds cats = case cats of
@@ -57,15 +64,3 @@ genRandom gen pgf (DTyp _ cat _) = genTrees (randomRs (0.0, 1.0 :: Double) gen)
_ -> ([],0) _ -> ([],0)
fns cat = [(f,(fst (catSkeleton ty))) | (f,ty) <- functionsToCat pgf cat] fns cat = [(f,(fst (catSkeleton ty))) | (f,ty) <- functionsToCat pgf cat]
{-
-- brute-force parsing method; only returns the first result
-- note: you cannot throw away rules with unknown words from the grammar
-- because it is not known which field in each rule may match the input
searchParse :: Int -> PGF -> CId -> [String] -> [Exp]
searchParse i pgf cat ws = [t | t <- gen, s <- lins t, words s == ws] where
gen = take i $ generate pgf cat
lins t = [linearize pgf lang t | lang <- cncnames pgf]
-}

13
src/PGF/Linearize.hs
View File

@@ -4,6 +4,7 @@ module PGF.Linearize
import PGF.CId import PGF.CId
import PGF.Data import PGF.Data
import PGF.Macros import PGF.Macros
import PGF.Tree
import Control.Monad import Control.Monad
import qualified Data.Map as Map import qualified Data.Map as Map
@@ -13,7 +14,7 @@ import Debug.Trace
-- linearization and computation of concrete PGF Terms -- linearization and computation of concrete PGF Terms
linearizes :: PGF -> CId -> Tree -> [String] linearizes :: PGF -> CId -> Expr -> [String]
linearizes pgf lang = realizes . linTree pgf lang linearizes pgf lang = realizes . linTree pgf lang
realize :: Term -> String realize :: Term -> String
@@ -54,8 +55,8 @@ liftVariants = f
f (W s t) = liftM (W s) $ f t f (W s t) = liftM (W s) $ f t
f t = return t f t = return t
linTree :: PGF -> CId -> Tree -> Term linTree :: PGF -> CId -> Expr -> Term
linTree pgf lang = lin linTree pgf lang = lin . expr2tree
where where
lin (Abs xs e ) = case lin e of lin (Abs xs e ) = case lin e of
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs) R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
@@ -122,11 +123,11 @@ compute pgf lang args = comp where
--------- ---------
-- markup with tree positions -- markup with tree positions
linearizesMark :: PGF -> CId -> Tree -> [String] linearizesMark :: PGF -> CId -> Expr -> [String]
linearizesMark pgf lang = realizes . linTreeMark pgf lang linearizesMark pgf lang = realizes . linTreeMark pgf lang
linTreeMark :: PGF -> CId -> Tree -> Term linTreeMark :: PGF -> CId -> Expr -> Term
linTreeMark pgf lang = lin [] linTreeMark pgf lang = lin [] . expr2tree
where where
lin p (Abs xs e ) = case lin p e of lin p (Abs xs e ) = case lin p e of
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs) R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)

8
src/PGF/Macros.hs
View File

@@ -99,10 +99,10 @@ restrictPGF cond pgf = pgf {
restrict = Map.filterWithKey (\c _ -> cond c) restrict = Map.filterWithKey (\c _ -> cond c)
abstr = abstract pgf abstr = abstract pgf
depth :: Tree -> Int depth :: Expr -> Int
depth (Abs _ t) = depth t depth (EAbs _ t) = depth t
depth (Fun _ ts) = maximum (0:map depth ts) + 1 depth (EApp e1 e2) = max (depth e1) (depth e2) + 1
depth _ = 1 depth _ = 1
cftype :: [CId] -> CId -> Type cftype :: [CId] -> CId -> Type
cftype args val = DTyp [Hyp (cftype [] arg) | arg <- args] val [] cftype args val = DTyp [Hyp (cftype [] arg) | arg <- args] val []

2
src/PGF/PMCFG.hs
View File

@@ -23,7 +23,7 @@ type Profile = [Int]
data Production data Production
= FApply {-# UNPACK #-} !FunId [FCat] = FApply {-# UNPACK #-} !FunId [FCat]
| FCoerce {-# UNPACK #-} !FCat | FCoerce {-# UNPACK #-} !FCat
| FConst Tree [String] | FConst Expr [String]
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
data FFun = FFun CId [Profile] {-# UNPACK #-} !(UArray FIndex SeqId) deriving (Eq,Ord,Show) data FFun = FFun CId [Profile] {-# UNPACK #-} !(UArray FIndex SeqId) deriving (Eq,Ord,Show)
type FSeq = Array FPointPos FSymbol type FSeq = Array FPointPos FSymbol

14
src/PGF/Paraphrase.hs
View File

@@ -14,6 +14,7 @@ module PGF.Paraphrase (
) where ) where
import PGF.Data import PGF.Data
import PGF.Tree
import PGF.Macros (lookDef,isData) import PGF.Macros (lookDef,isData)
import PGF.Expr import PGF.Expr
import PGF.CId import PGF.CId
@@ -23,15 +24,18 @@ import qualified Data.Map as Map
import Debug.Trace ---- import Debug.Trace ----
paraphrase :: PGF -> Tree -> [Tree] paraphrase :: PGF -> Expr -> [Expr]
paraphrase pgf = nub . paraphraseN 2 pgf paraphrase pgf = nub . paraphraseN 2 pgf
paraphraseN :: Int -> PGF -> Tree -> [Tree] paraphraseN :: Int -> PGF -> Expr -> [Expr]
paraphraseN 0 _ t = [t] paraphraseN i pgf = map tree2expr . paraphraseN' i pgf . expr2tree
paraphraseN i pgf t =
paraphraseN' :: Int -> PGF -> Tree -> [Tree]
paraphraseN' 0 _ t = [t]
paraphraseN' i pgf t =
step i t ++ [Fun g ts' | Fun g ts <- step (i-1) t, ts' <- sequence (map par ts)] step i t ++ [Fun g ts' | Fun g ts <- step (i-1) t, ts' <- sequence (map par ts)]
where where
par = paraphraseN (i-1) pgf par = paraphraseN' (i-1) pgf
step 0 t = [t] step 0 t = [t]
step i t = let stept = step (i-1) t in stept ++ concat [def u | u <- stept] step i t = let stept = step (i-1) t in stept ++ concat [def u | u <- stept]
def = fromDef pgf def = fromDef pgf

39
src/PGF/Parsing/FCFG.hs
View File

@@ -1,39 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : Krasimir Angelov
-- Stability : (stable)
-- Portability : (portable)
--
-- FCFG parsing
-----------------------------------------------------------------------------
module PGF.Parsing.FCFG
(ParserInfo,parseFCFG) where
import GF.Data.ErrM
import GF.Data.Assoc
import GF.Data.SortedList
import PGF.CId
import PGF.Data
import PGF.Macros
import PGF.Parsing.FCFG.Utilities
import qualified PGF.Parsing.FCFG.Active as Active
import qualified PGF.Parsing.FCFG.Incremental as Incremental
import qualified Data.Map as Map
----------------------------------------------------------------------
-- parsing
-- main parsing function
parseFCFG :: String -- ^ parsing strategy
-> ParserInfo -- ^ compiled grammar (fcfg)
-> Type -- ^ start type
-> [String] -- ^ input tokens
-> Err [Tree] -- ^ resulting GF terms
parseFCFG "bottomup" pinfo typ toks = return $ Active.parse "b" pinfo typ toks
parseFCFG "topdown" pinfo typ toks = return $ Active.parse "t" pinfo typ toks
parseFCFG "incremental" pinfo typ toks = return $ Incremental.parse pinfo typ toks
parseFCFG strat pinfo typ toks = fail $ "FCFG parsing strategy not defined: " ++ strat

5
src/PGF/Parsing/FCFG/Active.hs
View File

@@ -16,6 +16,7 @@ import qualified GF.Data.MultiMap as MM
import PGF.CId import PGF.CId
import PGF.Data import PGF.Data
import PGF.Tree
import PGF.Parsing.FCFG.Utilities import PGF.Parsing.FCFG.Utilities
import PGF.BuildParser import PGF.BuildParser
@@ -37,8 +38,8 @@ makeFinalEdge cat 0 0 = (cat, [EmptyRange])
makeFinalEdge cat i j = (cat, [makeRange i j]) makeFinalEdge cat i j = (cat, [makeRange i j])
-- | the list of categories = possible starting categories -- | the list of categories = possible starting categories
parse :: String -> ParserInfo -> Type -> [FToken] -> [Tree] parse :: String -> ParserInfo -> Type -> [FToken] -> [Expr]
parse strategy pinfo (DTyp _ start _) toks = nubsort $ filteredForests >>= forest2trees parse strategy pinfo (DTyp _ start _) toks = map (tree2expr) . nubsort $ filteredForests >>= forest2trees
where where
inTokens = input toks inTokens = input toks
starts = Map.findWithDefault [] start (startCats pinfo) starts = Map.findWithDefault [] start (startCats pinfo)

67
src/PGF/Parsing/FCFG/Incremental.hs
View File

@@ -21,13 +21,17 @@ import Control.Monad
import GF.Data.SortedList import GF.Data.SortedList
import PGF.CId import PGF.CId
import PGF.Data import PGF.Data
import PGF.Macros
import PGF.TypeCheck
import Debug.Trace import Debug.Trace
parse :: ParserInfo -> Type -> [String] -> [Tree] parse :: PGF -> Language -> Type -> [String] -> [Expr]
parse pinfo typ toks = maybe [] (\ps -> extractExps ps typ) (foldM nextState (initState pinfo typ) toks) parse pgf lang typ toks = maybe [] (\ps -> extractExps ps typ) (foldM nextState (initState pgf lang typ) toks)
initState :: ParserInfo -> Type -> ParseState -- | Creates an initial parsing state for a given language and
initState pinfo (DTyp _ start _) = -- startup category.
initState :: PGF -> Language -> Type -> ParseState
initState pgf lang (DTyp _ start _) =
let items = do let items = do
cat <- fromMaybe [] (Map.lookup start (startCats pinfo)) cat <- fromMaybe [] (Map.lookup start (startCats pinfo))
(funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args) (funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args)
@@ -35,8 +39,14 @@ initState pinfo (DTyp _ start _) =
let FFun fn _ lins = functions pinfo ! funid let FFun fn _ lins = functions pinfo ! funid
(lbl,seqid) <- assocs lins (lbl,seqid) <- assocs lins
return (Active 0 0 funid seqid args (AK cat lbl)) return (Active 0 0 funid seqid args (AK cat lbl))
in State pinfo pinfo =
case lookParser pgf lang of
Just pinfo -> pinfo
_ -> error ("Unknown language: " ++ prCId lang)
in State pgf
pinfo
(Chart emptyAC [] emptyPC (productions pinfo) (totalCats pinfo) 0) (Chart emptyAC [] emptyPC (productions pinfo) (totalCats pinfo) 0)
(TMap.singleton [] (Set.fromList items)) (TMap.singleton [] (Set.fromList items))
@@ -44,7 +54,7 @@ initState pinfo (DTyp _ start _) =
-- 'nextState' computes a new state where the token -- 'nextState' computes a new state where the token
-- is consumed and the current position shifted by one. -- is consumed and the current position shifted by one.
nextState :: ParseState -> String -> Maybe ParseState nextState :: ParseState -> String -> Maybe ParseState
nextState (State pinfo chart items) t = nextState (State pgf pinfo chart items) t =
let (mb_agenda,map_items) = TMap.decompose items let (mb_agenda,map_items) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda agenda = maybe [] Set.toList mb_agenda
acc = fromMaybe TMap.empty (Map.lookup t map_items) acc = fromMaybe TMap.empty (Map.lookup t map_items)
@@ -56,7 +66,7 @@ nextState (State pinfo chart items) t =
} }
in if TMap.null acc1 in if TMap.null acc1
then Nothing then Nothing
else Just (State pinfo chart2 acc1) else Just (State pgf pinfo chart2 acc1)
where where
add (tok:toks) item acc add (tok:toks) item acc
| tok == t = TMap.insertWith Set.union toks (Set.singleton item) acc | tok == t = TMap.insertWith Set.union toks (Set.singleton item) acc
@@ -67,7 +77,7 @@ nextState (State pinfo chart items) t =
-- next words and the consequent states. This is used for word completions in -- next words and the consequent states. This is used for word completions in
-- the GF interpreter. -- the GF interpreter.
getCompletions :: ParseState -> String -> Map.Map String ParseState getCompletions :: ParseState -> String -> Map.Map String ParseState
getCompletions (State pinfo chart items) w = getCompletions (State pgf pinfo chart items) w =
let (mb_agenda,map_items) = TMap.decompose items let (mb_agenda,map_items) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda agenda = maybe [] Set.toList mb_agenda
acc = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items acc = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items
@@ -77,20 +87,25 @@ getCompletions (State pinfo chart items) w =
, passive=emptyPC , passive=emptyPC
, offset =offset chart1+1 , offset =offset chart1+1
} }
in fmap (State pinfo chart2) acc' in fmap (State pgf pinfo chart2) acc'
where where
add (tok:toks) item acc add (tok:toks) item acc
| isPrefixOf w tok = Map.insertWith (TMap.unionWith Set.union) tok (TMap.singleton toks (Set.singleton item)) acc | isPrefixOf w tok = Map.insertWith (TMap.unionWith Set.union) tok (TMap.singleton toks (Set.singleton item)) acc
add _ item acc = acc add _ item acc = acc
extractExps :: ParseState -> Type -> [Tree] -- | This function extracts the list of all completed parse trees
extractExps (State pinfo chart items) (DTyp _ start _) = exps -- that spans the whole input consumed so far. The trees are also
-- limited by the category specified, which is usually
-- the same as the startup category.
extractExps :: ParseState -> Type -> [Expr]
extractExps (State pgf pinfo chart items) ty@(DTyp _ start _) =
nubsort [e1 | e <- exps, Right e1 <- [checkExpr pgf e ty]]
where where
(mb_agenda,acc) = TMap.decompose items (mb_agenda,acc) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda agenda = maybe [] Set.toList mb_agenda
(_,st) = process Nothing (\_ _ -> id) (sequences pinfo) (functions pinfo) agenda () chart (_,st) = process Nothing (\_ _ -> id) (sequences pinfo) (functions pinfo) agenda () chart
exps = nubsort $ do exps = do
cat <- fromMaybe [] (Map.lookup start (startCats pinfo)) cat <- fromMaybe [] (Map.lookup start (startCats pinfo))
(funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args) (funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args)
[] cat (productions pinfo) [] cat (productions pinfo)
@@ -102,7 +117,7 @@ extractExps (State pinfo chart items) (DTyp _ start _) = exps
return tree return tree
go rec fcat' (d,fcat) go rec fcat' (d,fcat)
| fcat < totalCats pinfo = return (Set.empty,Meta (fcat'*10+d)) -- FIXME: here we assume that every rule has at most 10 arguments | fcat < totalCats pinfo = return (Set.empty,EMeta (fcat'*10+d)) -- FIXME: here we assume that every rule has at most 10 arguments
| Set.member fcat rec = mzero | Set.member fcat rec = mzero
| otherwise = foldForest (\funid args trees -> | otherwise = foldForest (\funid args trees ->
do let FFun fn _ lins = functions pinfo ! funid do let FFun fn _ lins = functions pinfo ! funid
@@ -118,14 +133,14 @@ extractExps (State pinfo chart items) (DTyp _ start _) = exps
check_ho_fun fun args check_ho_fun fun args
| fun == _V = return (head args) | fun == _V = return (head args)
| fun == _B = return (foldl1 Set.difference (map fst args),Abs [mkVar (snd e) | e <- tail args] (snd (head args))) | fun == _B = return (foldl1 Set.difference (map fst args), foldr (\x e -> EAbs (mkVar (snd x)) e) (snd (head args)) (tail args))
| otherwise = return (Set.unions (map fst args),Fun fun (map snd args)) | otherwise = return (Set.unions (map fst args),foldl (\e x -> EApp e (snd x)) (EFun fun) args)
mkVar (Var v) = v mkVar (EFun v) = v
mkVar (Meta _) = wildCId mkVar (EMeta _) = wildCId
freeVar (Var v) = Set.singleton v freeVar (EFun v) = Set.singleton v
freeVar _ = Set.empty freeVar _ = Set.empty
_B = mkCId "_B" _B = mkCId "_B"
_V = mkCId "_V" _V = mkCId "_V"
@@ -194,12 +209,12 @@ updateAt :: Int -> a -> [a] -> [a]
updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs] updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs]
litCatMatch fcat (Just t) litCatMatch fcat (Just t)
| fcat == fcatString = Just ([t],Lit (LStr t)) | fcat == fcatString = Just ([t],ELit (LStr t))
| fcat == fcatInt = case reads t of {[(n,"")] -> Just ([t],Lit (LInt n)); | fcat == fcatInt = case reads t of {[(n,"")] -> Just ([t],ELit (LInt n));
_ -> Nothing } _ -> Nothing }
| fcat == fcatFloat = case reads t of {[(d,"")] -> Just ([t],Lit (LFlt d)); | fcat == fcatFloat = case reads t of {[(d,"")] -> Just ([t],ELit (LFlt d));
_ -> Nothing } _ -> Nothing }
| fcat == fcatVar = Just ([t],Var (mkCId t)) | fcat == fcatVar = Just ([t],EFun (mkCId t))
litCatMatch _ _ = Nothing litCatMatch _ _ = Nothing
@@ -263,7 +278,7 @@ insertPC key fcat chart = Map.insert key fcat chart
-- Forest -- Forest
---------------------------------------------------------------- ----------------------------------------------------------------
foldForest :: (FunId -> [FCat] -> b -> b) -> (Tree -> [String] -> b -> b) -> b -> FCat -> IntMap.IntMap (Set.Set Production) -> b foldForest :: (FunId -> [FCat] -> b -> b) -> (Expr -> [String] -> b -> b) -> b -> FCat -> IntMap.IntMap (Set.Set Production) -> b
foldForest f g b fcat forest = foldForest f g b fcat forest =
case IntMap.lookup fcat forest of case IntMap.lookup fcat forest of
Nothing -> b Nothing -> b
@@ -280,7 +295,7 @@ foldForest f g b fcat forest =
-- | An abstract data type whose values represent -- | An abstract data type whose values represent
-- the current state in an incremental parser. -- the current state in an incremental parser.
data ParseState = State ParserInfo Chart (TMap.TrieMap String (Set.Set Active)) data ParseState = State PGF ParserInfo Chart (TMap.TrieMap String (Set.Set Active))
data Chart data Chart
= Chart = Chart

1
src/PGF/Parsing/FCFG/Utilities.hs
View File

@@ -20,6 +20,7 @@ import Data.List (groupBy)
import PGF.CId import PGF.CId
import PGF.Data import PGF.Data
import PGF.Tree
import GF.Data.Assoc import GF.Data.Assoc
import GF.Data.Utilities (sameLength, foldMerge, splitBy) import GF.Data.Utilities (sameLength, foldMerge, splitBy)

21
src/PGF/ShowLinearize.hs
View File

@@ -10,6 +10,7 @@ module PGF.ShowLinearize (
import PGF.CId import PGF.CId
import PGF.Data import PGF.Data
import PGF.Tree
import PGF.Macros import PGF.Macros
import PGF.Linearize import PGF.Linearize
@@ -57,17 +58,17 @@ mkRecord typ trm = case (typ,trm) of
str = realize str = realize
-- show all branches, without labels and params -- show all branches, without labels and params
allLinearize :: (String -> String) -> PGF -> CId -> Tree -> String allLinearize :: (String -> String) -> PGF -> CId -> Expr -> String
allLinearize unlex pgf lang = concat . map (unlex . pr) . tabularLinearize pgf lang where allLinearize unlex pgf lang = concat . map (unlex . pr) . tabularLinearize pgf lang where
pr (p,vs) = unlines vs pr (p,vs) = unlines vs
-- show all branches, with labels and params -- show all branches, with labels and params
tableLinearize :: (String -> String) -> PGF -> CId -> Tree -> String tableLinearize :: (String -> String) -> PGF -> CId -> Expr -> String
tableLinearize unlex pgf lang = unlines . map pr . tabularLinearize pgf lang where tableLinearize unlex pgf lang = unlines . map pr . tabularLinearize pgf lang where
pr (p,vs) = p +++ ":" +++ unwords (intersperse "|" (map unlex vs)) pr (p,vs) = p +++ ":" +++ unwords (intersperse "|" (map unlex vs))
-- create a table from labels+params to variants -- create a table from labels+params to variants
tabularLinearize :: PGF -> CId -> Tree -> [(String,[String])] tabularLinearize :: PGF -> CId -> Expr -> [(String,[String])]
tabularLinearize pgf lang = branches . recLinearize pgf lang where tabularLinearize pgf lang = branches . recLinearize pgf lang where
branches r = case r of branches r = case r of
RR fs -> [(lab +++ b,s) | (lab,t) <- fs, (b,s) <- branches t] RR fs -> [(lab +++ b,s) | (lab,t) <- fs, (b,s) <- branches t]
@@ -77,22 +78,22 @@ tabularLinearize pgf lang = branches . recLinearize pgf lang where
RCon _ -> [] RCon _ -> []
-- show record in GF-source-like syntax -- show record in GF-source-like syntax
recordLinearize :: PGF -> CId -> Tree -> String recordLinearize :: PGF -> CId -> Expr -> String
recordLinearize pgf lang = prRecord . recLinearize pgf lang recordLinearize pgf lang = prRecord . recLinearize pgf lang
-- create a GF-like record, forming the basis of all functions above -- create a GF-like record, forming the basis of all functions above
recLinearize :: PGF -> CId -> Tree -> Record recLinearize :: PGF -> CId -> Expr -> Record
recLinearize pgf lang tree = mkRecord typ $ linTree pgf lang tree where recLinearize pgf lang tree = mkRecord typ $ linTree pgf lang tree where
typ = case tree of typ = case expr2tree tree of
Fun f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f Fun f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f
-- show PGF term -- show PGF term
termLinearize :: PGF -> CId -> Tree -> String termLinearize :: PGF -> CId -> Expr -> String
termLinearize pgf lang = show . linTree pgf lang termLinearize pgf lang = show . linTree pgf lang
-- show bracketed markup with references to tree structure -- show bracketed markup with references to tree structure
markLinearize :: PGF -> CId -> Tree -> String markLinearize :: PGF -> CId -> Expr -> String
markLinearize pgf lang t = concat $ take 1 $ linearizesMark pgf lang t markLinearize pgf lang = concat . take 1 . linearizesMark pgf lang
-- for Morphology: word, lemma, tags -- for Morphology: word, lemma, tags
@@ -102,7 +103,7 @@ collectWords pgf lang =
[(f,c,0) | (f,(DTyp [] c _,_,_)) <- Map.toList $ funs $ abstract pgf] [(f,c,0) | (f,(DTyp [] c _,_,_)) <- Map.toList $ funs $ abstract pgf]
where where
collOne (f,c,i) = collOne (f,c,i) =
fromRec f [prCId c] (recLinearize pgf lang (Fun f (replicate i (Meta 888)))) fromRec f [prCId c] (recLinearize pgf lang (foldl EApp (EFun f) (replicate i (EMeta 888))))
fromRec f v r = case r of fromRec f v r = case r of
RR rs -> concat [fromRec f v t | (_,t) <- rs] RR rs -> concat [fromRec f v t | (_,t) <- rs]
RT rs -> concat [fromRec f (p:v) t | (p,t) <- rs] RT rs -> concat [fromRec f (p:v) t | (p,t) <- rs]

107
src/PGF/Tree.hs Normal file
View File

@@ -0,0 +1,107 @@
module PGF.Tree
( Tree(..),
readTree, showTree, pTree, ppTree,
tree2expr, expr2tree
) where
import PGF.CId
import PGF.Expr
import Data.Char
import Data.List as List
import Control.Monad
import qualified Text.PrettyPrint as PP
import qualified Text.ParserCombinators.ReadP as RP
-- | The tree is an evaluated expression in the abstract syntax
-- of the grammar. The type is especially restricted to not
-- allow unapplied lambda abstractions. The tree is used directly
-- from the linearizer and is produced directly from the parser.
data Tree =
Abs [CId] Tree -- ^ lambda abstraction. The list of variables is non-empty
| Var CId -- ^ variable
| Fun CId [Tree] -- ^ function application
| Lit Literal -- ^ literal
| Meta {-# UNPACK #-} !MetaId -- ^ meta variable
deriving (Eq, Ord)
-- | parses 'String' as an expression
readTree :: String -> Maybe Tree
readTree s = case [x | (x,cs) <- RP.readP_to_S (pTree False) s, all isSpace cs] of
[x] -> Just x
_ -> Nothing
-- | renders expression as 'String'
showTree :: Tree -> String
showTree = PP.render . ppTree 0
instance Show Tree where
showsPrec i x = showString (PP.render (ppTree i x))
instance Read Tree where
readsPrec _ = RP.readP_to_S (pTree False)
pTrees :: RP.ReadP [Tree]
pTrees = liftM2 (:) (pTree True) pTrees RP.<++ (RP.skipSpaces >> return [])
pTree :: Bool -> RP.ReadP Tree
pTree isNested = RP.skipSpaces >> (pParen RP.<++ pAbs RP.<++ pApp RP.<++ fmap Lit pLit RP.<++ fmap Meta pMeta)
where
pParen = RP.between (RP.char '(') (RP.char ')') (pTree False)
pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") (RP.sepBy1 (RP.skipSpaces >> pCId) (RP.skipSpaces >> RP.char ','))
t <- pTree False
return (Abs xs t)
pApp = do f <- pCId
ts <- (if isNested then return [] else pTrees)
return (Fun f ts)
ppTree d (Abs xs t) = ppParens (d > 0) (PP.char '\\' PP.<>
PP.hsep (PP.punctuate PP.comma (List.map (PP.text . prCId) xs)) PP.<+>
PP.text "->" PP.<+>
ppTree 0 t)
ppTree d (Fun f []) = PP.text (prCId f)
ppTree d (Fun f ts) = ppParens (d > 0) (PP.text (prCId f) PP.<+> PP.hsep (List.map (ppTree 1) ts))
ppTree d (Lit l) = ppLit l
ppTree d (Meta n) = ppMeta n
ppTree d (Var id) = PP.text (prCId id)
-----------------------------------------------------
-- Conversion Expr <-> Tree
-----------------------------------------------------
-- | Converts a tree to expression. The conversion
-- is always total, every tree is a valid expression.
tree2expr :: Tree -> Expr
tree2expr = tree2expr []
where
tree2expr ys (Fun x ts) = foldl EApp (EFun x) (List.map (tree2expr ys) ts)
tree2expr ys (Lit l) = ELit l
tree2expr ys (Meta n) = EMeta n
tree2expr ys (Abs xs t) = foldr EAbs (tree2expr (reverse xs++ys) t) xs
tree2expr ys (Var x) = case List.lookup x (zip ys [0..]) of
Just i -> EVar i
Nothing -> error "unknown variable"
-- | Converts an expression to tree. The conversion is only partial.
-- Variables and meta variables of function type and beta redexes are not allowed.
expr2tree :: Expr -> Tree
expr2tree e = abs [] [] e
where
abs ys xs (EAbs x e) = abs ys (x:xs) e
abs ys xs (ETyped e _) = abs ys xs e
abs ys xs e = case xs of
[] -> app ys [] e
xs -> Abs (reverse xs) (app (xs++ys) [] e)
app xs as (EApp e1 e2) = app xs ((abs xs [] e2) : as) e1
app xs as (ELit l)
| List.null as = Lit l
| otherwise = error "literal of function type encountered"
app xs as (EMeta n)
| List.null as = Meta n
| otherwise = error "meta variables of function type are not allowed in trees"
app xs as (EAbs x e) = error "beta redexes are not allowed in trees"
app xs as (EVar i) = Var (xs !! i)
app xs as (EFun f) = Fun f as
app xs as (ETyped e _) = app xs as e

4
src/PGF/Type.hs
View File

@@ -82,7 +82,3 @@ ppHypo scope (HypV x typ) = let y = freshName x scope
in (y:scope,PP.parens (PP.text (prCId y) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ)) in (y:scope,PP.parens (PP.text (prCId y) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ))
ppHypo scope (HypI x typ) = let y = freshName x scope ppHypo scope (HypI x typ) = let y = freshName x scope
in (y:scope,PP.braces (PP.text (prCId y) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ)) in (y:scope,PP.braces (PP.text (prCId y) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ))
ppParens :: Bool -> PP.Doc -> PP.Doc
ppParens True = PP.parens
ppParens False = id

7
src/PGF/VisualizeTree.hs
View File

@@ -21,6 +21,7 @@ module PGF.VisualizeTree ( visualizeTrees, alignLinearize
import PGF.CId (prCId) import PGF.CId (prCId)
import PGF.Data import PGF.Data
import PGF.Tree
import PGF.Linearize import PGF.Linearize
import PGF.Macros (lookValCat) import PGF.Macros (lookValCat)
@@ -28,8 +29,8 @@ import Data.List (intersperse,nub)
import Data.Char (isDigit) import Data.Char (isDigit)
import qualified Text.ParserCombinators.ReadP as RP import qualified Text.ParserCombinators.ReadP as RP
visualizeTrees :: PGF -> (Bool,Bool) -> [Tree] -> String visualizeTrees :: PGF -> (Bool,Bool) -> [Expr] -> String
visualizeTrees pgf funscats = unlines . map (prGraph False . tree2graph pgf funscats) visualizeTrees pgf funscats = unlines . map (prGraph False . tree2graph pgf funscats . expr2tree)
tree2graph :: PGF -> (Bool,Bool) -> Tree -> [String] tree2graph :: PGF -> (Bool,Bool) -> Tree -> [String]
tree2graph pgf (funs,cats) = prf [] where tree2graph pgf (funs,cats) = prf [] where
@@ -57,7 +58,7 @@ prGraph digr ns = concat $ map (++"\n") $ [graph ++ "{\n"] ++ ns ++ ["}"] where
-- word alignments from Linearize.linearizesMark -- word alignments from Linearize.linearizesMark
-- words are chunks like {[0,1,1,0] old} -- words are chunks like {[0,1,1,0] old}
alignLinearize :: PGF -> Tree -> String alignLinearize :: PGF -> Expr -> String
alignLinearize pgf = prGraph True . lin2graph . linsMark where alignLinearize pgf = prGraph True . lin2graph . linsMark where
linsMark t = [s | la <- cncnames pgf, s <- take 1 (linearizesMark pgf la t)] linsMark t = [s | la <- cncnames pgf, s <- take 1 (linearizesMark pgf la t)]