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

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.Active
PGF.Parsing.FCFG.Incremental
PGF.Parsing.FCFG
PGF.Expr
PGF.Type
PGF.Tree
PGF.PMCFG
PGF.Paraphrase
PGF.TypeCheck
@@ -160,6 +160,7 @@ executable gf
PGF.Data
PGF.Expr
PGF.Type
PGF.Tree
PGF.PMCFG
PGF.Macros
PGF.Generate
@@ -167,7 +168,6 @@ executable gf
PGF.BuildParser
PGF.Parsing.FCFG.Utilities
PGF.Parsing.FCFG.Active
PGF.Parsing.FCFG
PGF.Binary
PGF.Paraphrase
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.UseIO
import GF.Data.ErrM ----
import PGF.Expr (readTree)
import GF.Command.Abstract
import GF.Command.Messages
import GF.Text.Lexing
@@ -140,8 +139,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
"flag -format."
],
exec = \opts es -> do
let ts = toTrees es
grph = if null ts then [] else alignLinearize pgf (head ts)
let grph = if null es then [] else alignLinearize pgf (head es)
if isFlag "view" opts || isFlag "format" opts then do
let file s = "_grph." ++ s
let view = optViewGraph opts ++ " "
@@ -241,7 +239,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
exec = \opts _ -> do
let pgfr = optRestricted opts
ts <- generateRandom pgfr (optType opts)
return $ fromTrees $ take (optNum opts) ts
returnFromExprs $ take (optNum opts) ts
}),
("gt", emptyCommandInfo {
longname = "generate_trees",
@@ -262,7 +260,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
let pgfr = optRestricted opts
let dp = return $ valIntOpts "depth" 4 opts
let ts = generateAllDepth pgfr (optType opts) dp
returnFromTrees $ take (optNumInf opts) ts
returnFromExprs $ take (optNumInf opts) ts
}),
("h", emptyCommandInfo {
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",
"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 = [
("all","show all forms and variants"),
("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.",
"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 = [
("cat","target category of parsing"),
("lang","the languages of parsing (comma-separated, no spaces)")
@@ -490,13 +488,13 @@ allCommands cod env@(pgf, mos) = Map.fromList [
exec = \opts _ -> do
let file = valStrOpts "file" "_gftmp" opts
s <- readFile file
return $ case opts of
_ | isOpt "lines" opts && isOpt "tree" opts ->
fromTrees [t | l <- lines s, Just t <- [readTree l]]
case opts of
_ | isOpt "lines" opts && isOpt "tree" opts ->
returnFromExprs [e | l <- lines s, Just e0 <- [readExpr l], Right (e,t) <- [inferExpr pgf e0]]
_ | isOpt "tree" opts ->
fromTrees [t | Just t <- [readTree s]]
_ | isOpt "lines" opts -> fromStrings $ lines s
_ -> fromString s,
returnFromExprs [e | Just e0 <- [readExpr s], Right (e,t) <- [inferExpr pgf e0]]
_ | isOpt "lines" opts -> return (fromStrings $ lines s)
_ -> return (fromString s),
flags = [("file","the input file name")]
}),
("tq", emptyCommandInfo {
@@ -565,10 +563,9 @@ allCommands cod env@(pgf, mos) = Map.fromList [
"flag -format."
],
exec = \opts es -> do
let ts = toTrees es
funs = not (isOpt "nofun" opts)
let funs = not (isOpt "nofun" 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
let file s = "_grph." ++ s
let view = optViewGraph opts ++ " "
@@ -644,26 +641,24 @@ allCommands cod env@(pgf, mos) = Map.fromList [
]
where
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]
void = ([],[])
optLin opts t = case opts of
_ | isOpt "treebank" opts -> treebank opts t
_ -> unlines [linear opts lang t | lang <- optLangs opts]
optLin opts t = unlines $
case opts of
_ | 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
_ | isOpt "all" opts -> allLinearize unl pgf lang
_ | isOpt "table" opts -> tableLinearize unl pgf lang
_ | isOpt "term" opts -> termLinearize pgf lang
_ | isOpt "record" opts -> recordLinearize pgf lang
_ | isOpt "bracket" opts -> markLinearize pgf lang
_ -> unl . linearize pgf lang
treebank opts t = unlines $
(prCId (abstractName pgf) ++ ": " ++ showTree t) :
[prCId lang ++ ": " ++ linear opts lang t | lang <- optLangs opts]
_ -> unl . linearize pgf lang
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
optNum opts = valIntOpts "number" 1 opts
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)
fromString s = ([ELit (LStr s)], s)
toTrees = map expr2tree
toStrings = map showAsString
toString = unwords . toStrings
returnFromTrees ts = return $ case ts of
[] -> ([], "no trees found")
_ -> fromTrees ts
returnFromExprs es = return $ case es of
[] -> ([], "no trees found")
_ -> (es,unlines (map (showExpr []) es))
_ -> fromExprs es
prGrammar opts
| 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.Expr
import PGF.Data(Tree)
import GF.Command.Abstract
import Data.Char

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

@@ -18,7 +18,7 @@ allTreeOps pgf = [
("compute",("compute by using semantic definitions (def)",
map (compute pgf))),
("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))
]

1
src/GF/Quiz.hs
View File

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

1
src/GFI.hs
View File

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

75
src/PGF.hs
View File

@@ -33,13 +33,9 @@ module PGF(
-- * Expressions
-- ** Identifiers
CId, mkCId, prCId, wildCId,
-- ** Tree
Tree(..), Literal(..),
showTree, readTree,
-- ** Expr
Expr(..), Equation(..),
Literal(..), Expr(..),
showExpr, readExpr,
-- * Operations
@@ -51,7 +47,7 @@ module PGF(
parse, canParse, parseAllLang, parseAll,
-- ** Evaluation
tree2expr, expr2tree, PGF.compute, paraphrase,
PGF.compute, paraphrase,
-- ** Type Checking
checkType, checkExpr, inferExpr,
@@ -60,7 +56,7 @@ module PGF(
-- ** Word Completion (Incremental Parsing)
complete,
Incremental.ParseState,
initState, Incremental.nextState, Incremental.getCompletions, extractExps,
Incremental.initState, Incremental.nextState, Incremental.getCompletions, Incremental.extractExps,
-- ** Generation
generateRandom, generateAll, generateAllDepth
@@ -74,12 +70,11 @@ import PGF.Paraphrase
import PGF.Macros
import PGF.Data hiding (functions)
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 GF.Compile.GeneratePMCFG as PMCFG
import GF.Infra.Option
import GF.Data.ErrM
import GF.Data.Utilities (replace)
import Data.Char
@@ -94,19 +89,6 @@ import Control.Monad
-- 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
-- 'PGF' structure. The file is usually produced with:
--
@@ -114,7 +96,7 @@ showLanguage :: Language -> String
readPGF :: FilePath -> IO PGF
-- | 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
-- 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.
-- Throws an exception if the given language cannot be used
-- 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.
canParse :: PGF -> Language -> Bool
-- | The same as 'linearizeAllLang' but does not return
-- the language.
linearizeAll :: PGF -> Tree -> [String]
linearizeAll :: PGF -> Expr -> [String]
-- | Linearizes given expression as string in all languages
-- available in the grammar.
linearizeAllLang :: PGF -> Tree -> [(Language,String)]
linearizeAllLang :: PGF -> Expr -> [(Language,String)]
-- | Show the printname of a type
showPrintName :: PGF -> Language -> Type -> String
-- | The same as 'parseAllLang' but does not return
-- the language.
parseAll :: PGF -> Type -> String -> [[Tree]]
parseAll :: PGF -> Type -> String -> [[Expr]]
-- | Tries to parse the given string with all available languages.
-- 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).
-- Only those languages
-- for which at least one parsing is possible are listed.
parseAllLang :: PGF -> Type -> String -> [(Language,[Tree])]
-- | 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]
parseAllLang :: PGF -> Type -> String -> [(Language,[Expr])]
-- | The same as 'generateAllDepth' but does not limit
-- the depth in the generation.
generateAll :: PGF -> Type -> [Tree]
generateAll :: PGF -> Type -> [Expr]
-- | Generates an infinite list of random abstract syntax expressions.
-- This is usefull for tree bank generation which after that can be used
-- for grammar testing.
generateRandom :: PGF -> Type -> IO [Tree]
generateRandom :: PGF -> Type -> IO [Expr]
-- | Generates an exhaustive possibly infinite list of
-- abstract syntax expressions. A depth can be specified
-- 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.
languages :: PGF -> [Language]
@@ -221,10 +193,6 @@ complete :: PGF -> Language -> Type -> String
-- Implementation
---------------------------------------------------
readLanguage = readCId
showLanguage = prCId
readPGF f = decodeFile f >>= addParsers
-- 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
Just cnc -> case parser cnc of
Just pinfo -> if Map.lookup (mkCId "erasing") (cflags cnc) == Just "on"
then Incremental.parse pinfo typ (words s)
else case parseFCFG "topdown" pinfo typ (words s) of
Ok x -> x
Bad s -> error s
then Incremental.parse pgf lang typ (words s)
else Active.parse "t" pinfo typ (words s)
Nothing -> error ("No parser built for 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 =
[(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
gen <- newStdGen
return $ genRandom gen pgf cat
@@ -297,11 +256,11 @@ functionType pgf fun =
complete pgf from typ 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
Nothing -> []
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)]
where
tokensAndPrefix :: String -> ([String],String)

15
src/PGF/Data.hs
View File

@@ -78,3 +78,18 @@ emptyPGF = PGF {
abstract = error "empty grammar, no abstract",
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(..),
readTree, showTree, pTree, ppTree,
Expr(..), Patt(..), Equation(..),
module PGF.Expr(Expr(..), Literal(..), Patt(..), Equation(..),
readExpr, showExpr, pExpr, ppExpr, ppPatt,
tree2expr, expr2tree, normalForm,
normalForm,
-- needed in the typechecker
Value(..), Env, Funs, eval, apply,
@@ -12,7 +9,7 @@ module PGF.Expr(Tree(..), Literal(..),
MetaId,
-- helpers
pStr,pFactor,freshName,ppMeta
pMeta,pStr,pFactor,pLit,freshName,ppMeta,ppLit,ppParens
) where
import PGF.CId
@@ -34,18 +31,6 @@ data Literal =
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
-- in the abstract syntax of the grammar.
data Expr =
@@ -74,22 +59,6 @@ data Equation =
Equ [Patt] Expr
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
readExpr :: String -> Maybe Expr
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
-----------------------------------------------------
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 = pExpr0 >>= optTyped
where
@@ -169,17 +124,6 @@ pStr = RP.char '"' >> (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"'))
-- 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 d scope (EAbs x e) = let (xs,e1) = getVars [x] e
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))
| 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

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

@@ -14,4 +14,6 @@ pFactor :: RP.ReadP Expr
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.Data
import PGF.Macros
import PGF.TypeCheck
import qualified Data.Map as M
import System.Random
-- generate an infinite list of trees exhaustively
generate :: PGF -> Type -> Maybe Int -> [Tree]
generate pgf (DTyp _ cat _) dp = concatMap (\i -> gener i cat) depths
generate :: PGF -> Type -> Maybe Int -> [Expr]
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
gener 0 c = [Fun f [] | (f, ([],_)) <- fns c]
gener 0 c = [EFun f | (f, ([],_)) <- fns c]
gener i c = [
tr |
(f, (cs,_)) <- fns c,
let alts = map (gener (i-1)) cs,
ts <- combinations alts,
let tr = Fun f ts,
let tr = foldl EApp (EFun f) ts,
depth tr >= i
]
fns c = [(f,catSkeleton ty) | (f,ty) <- functionsToCat pgf c]
depths = maybe [0 ..] (\d -> [0..d]) dp
-- generate an infinite list of trees randomly
genRandom :: StdGen -> PGF -> Type -> [Tree]
genRandom gen pgf (DTyp _ cat _) = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where
genRandom :: StdGen -> PGF -> Type -> [Expr]
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
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)
genTree rs = gett rs where
gett ds cid | cid == cidString = (Lit (LStr "foo"), 1)
gett ds cid | cid == cidInt = (Lit (LInt 12345), 1)
gett ds cid | cid == cidFloat = (Lit (LFlt 12345), 1)
gett [] _ = (Lit (LStr "TIMEOUT"), 1) ----
gett ds cid | cid == cidString = (ELit (LStr "foo"), 1)
gett ds cid | cid == cidInt = (ELit (LInt 12345), 1)
gett ds cid | cid == cidFloat = (ELit (LFlt 12345), 1)
gett [] _ = (ELit (LStr "TIMEOUT"), 1) ----
gett ds cat = case fns cat of
[] -> (Meta 0,1)
[] -> (EMeta 0,1)
fs -> let
d:ds2 = ds
(f,args) = getf d fs
(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
fs !! (floor (d * fromIntegral lg))
getts ds cats = case cats of
@@ -57,15 +64,3 @@ genRandom gen pgf (DTyp _ cat _) = genTrees (randomRs (0.0, 1.0 :: Double) gen)
_ -> ([],0)
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.Data
import PGF.Macros
import PGF.Tree
import Control.Monad
import qualified Data.Map as Map
@@ -13,7 +14,7 @@ import Debug.Trace
-- linearization and computation of concrete PGF Terms
linearizes :: PGF -> CId -> Tree -> [String]
linearizes :: PGF -> CId -> Expr -> [String]
linearizes pgf lang = realizes . linTree pgf lang
realize :: Term -> String
@@ -54,8 +55,8 @@ liftVariants = f
f (W s t) = liftM (W s) $ f t
f t = return t
linTree :: PGF -> CId -> Tree -> Term
linTree pgf lang = lin
linTree :: PGF -> CId -> Expr -> Term
linTree pgf lang = lin . expr2tree
where
lin (Abs xs e ) = case lin e of
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
@@ -122,11 +123,11 @@ compute pgf lang args = comp where
---------
-- markup with tree positions
linearizesMark :: PGF -> CId -> Tree -> [String]
linearizesMark :: PGF -> CId -> Expr -> [String]
linearizesMark pgf lang = realizes . linTreeMark pgf lang
linTreeMark :: PGF -> CId -> Tree -> Term
linTreeMark pgf lang = lin []
linTreeMark :: PGF -> CId -> Expr -> Term
linTreeMark pgf lang = lin [] . expr2tree
where
lin p (Abs xs e ) = case lin p e of
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)
abstr = abstract pgf
depth :: Tree -> Int
depth (Abs _ t) = depth t
depth (Fun _ ts) = maximum (0:map depth ts) + 1
depth _ = 1
depth :: Expr -> Int
depth (EAbs _ t) = depth t
depth (EApp e1 e2) = max (depth e1) (depth e2) + 1
depth _ = 1
cftype :: [CId] -> CId -> Type
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
= FApply {-# UNPACK #-} !FunId [FCat]
| FCoerce {-# UNPACK #-} !FCat
| FConst Tree [String]
| FConst Expr [String]
deriving (Eq,Ord,Show)
data FFun = FFun CId [Profile] {-# UNPACK #-} !(UArray FIndex SeqId) deriving (Eq,Ord,Show)
type FSeq = Array FPointPos FSymbol

14
src/PGF/Paraphrase.hs
View File

@@ -14,6 +14,7 @@ module PGF.Paraphrase (
) where
import PGF.Data
import PGF.Tree
import PGF.Macros (lookDef,isData)
import PGF.Expr
import PGF.CId
@@ -23,15 +24,18 @@ import qualified Data.Map as Map
import Debug.Trace ----
paraphrase :: PGF -> Tree -> [Tree]
paraphrase :: PGF -> Expr -> [Expr]
paraphrase pgf = nub . paraphraseN 2 pgf
paraphraseN :: Int -> PGF -> Tree -> [Tree]
paraphraseN 0 _ t = [t]
paraphraseN i pgf t =
paraphraseN :: Int -> PGF -> Expr -> [Expr]
paraphraseN i pgf = map tree2expr . paraphraseN' i pgf . expr2tree
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)]
where
par = paraphraseN (i-1) pgf
par = paraphraseN' (i-1) pgf
step 0 t = [t]
step i t = let stept = step (i-1) t in stept ++ concat [def u | u <- stept]
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.Data
import PGF.Tree
import PGF.Parsing.FCFG.Utilities
import PGF.BuildParser
@@ -37,8 +38,8 @@ makeFinalEdge cat 0 0 = (cat, [EmptyRange])
makeFinalEdge cat i j = (cat, [makeRange i j])
-- | the list of categories = possible starting categories
parse :: String -> ParserInfo -> Type -> [FToken] -> [Tree]
parse strategy pinfo (DTyp _ start _) toks = nubsort $ filteredForests >>= forest2trees
parse :: String -> ParserInfo -> Type -> [FToken] -> [Expr]
parse strategy pinfo (DTyp _ start _) toks = map (tree2expr) . nubsort $ filteredForests >>= forest2trees
where
inTokens = input toks
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 PGF.CId
import PGF.Data
import PGF.Macros
import PGF.TypeCheck
import Debug.Trace
parse :: ParserInfo -> Type -> [String] -> [Tree]
parse pinfo typ toks = maybe [] (\ps -> extractExps ps typ) (foldM nextState (initState pinfo typ) toks)
parse :: PGF -> Language -> Type -> [String] -> [Expr]
parse pgf lang typ toks = maybe [] (\ps -> extractExps ps typ) (foldM nextState (initState pgf lang typ) toks)
initState :: ParserInfo -> Type -> ParseState
initState pinfo (DTyp _ start _) =
-- | Creates an initial parsing state for a given language and
-- startup category.
initState :: PGF -> Language -> Type -> ParseState
initState pgf lang (DTyp _ start _) =
let items = do
cat <- fromMaybe [] (Map.lookup start (startCats pinfo))
(funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args)
@@ -35,8 +39,14 @@ initState pinfo (DTyp _ start _) =
let FFun fn _ lins = functions pinfo ! funid
(lbl,seqid) <- assocs lins
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)
(TMap.singleton [] (Set.fromList items))
@@ -44,7 +54,7 @@ initState pinfo (DTyp _ start _) =
-- 'nextState' computes a new state where the token
-- is consumed and the current position shifted by one.
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
agenda = maybe [] Set.toList mb_agenda
acc = fromMaybe TMap.empty (Map.lookup t map_items)
@@ -56,7 +66,7 @@ nextState (State pinfo chart items) t =
}
in if TMap.null acc1
then Nothing
else Just (State pinfo chart2 acc1)
else Just (State pgf pinfo chart2 acc1)
where
add (tok:toks) 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
-- the GF interpreter.
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
agenda = maybe [] Set.toList mb_agenda
acc = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items
@@ -77,20 +87,25 @@ getCompletions (State pinfo chart items) w =
, passive=emptyPC
, offset =offset chart1+1
}
in fmap (State pinfo chart2) acc'
in fmap (State pgf pinfo chart2) acc'
where
add (tok:toks) item acc
| isPrefixOf w tok = Map.insertWith (TMap.unionWith Set.union) tok (TMap.singleton toks (Set.singleton item)) acc
add _ item acc = acc
extractExps :: ParseState -> Type -> [Tree]
extractExps (State pinfo chart items) (DTyp _ start _) = exps
-- | 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 :: ParseState -> Type -> [Expr]
extractExps (State pgf pinfo chart items) ty@(DTyp _ start _) =
nubsort [e1 | e <- exps, Right e1 <- [checkExpr pgf e ty]]
where
(mb_agenda,acc) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda
(_,st) = process Nothing (\_ _ -> id) (sequences pinfo) (functions pinfo) agenda () chart
exps = nubsort $ do
exps = do
cat <- fromMaybe [] (Map.lookup start (startCats pinfo))
(funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args)
[] cat (productions pinfo)
@@ -102,7 +117,7 @@ extractExps (State pinfo chart items) (DTyp _ start _) = exps
return tree
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
| otherwise = foldForest (\funid args trees ->
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
| fun == _V = return (head args)
| fun == _B = return (foldl1 Set.difference (map fst args),Abs [mkVar (snd e) | e <- tail args] (snd (head args)))
| otherwise = return (Set.unions (map fst args),Fun fun (map snd 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),foldl (\e x -> EApp e (snd x)) (EFun fun) args)
mkVar (Var v) = v
mkVar (Meta _) = wildCId
mkVar (EFun v) = v
mkVar (EMeta _) = wildCId
freeVar (Var v) = Set.singleton v
freeVar _ = Set.empty
freeVar (EFun v) = Set.singleton v
freeVar _ = Set.empty
_B = mkCId "_B"
_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]
litCatMatch fcat (Just t)
| fcat == fcatString = Just ([t],Lit (LStr t))
| fcat == fcatInt = case reads t of {[(n,"")] -> Just ([t],Lit (LInt n));
| fcat == fcatString = Just ([t],ELit (LStr t))
| fcat == fcatInt = case reads t of {[(n,"")] -> Just ([t],ELit (LInt n));
_ -> 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 }
| fcat == fcatVar = Just ([t],Var (mkCId t))
| fcat == fcatVar = Just ([t],EFun (mkCId t))
litCatMatch _ _ = Nothing
@@ -263,7 +278,7 @@ insertPC key fcat chart = Map.insert key fcat chart
-- 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 =
case IntMap.lookup fcat forest of
Nothing -> b
@@ -280,7 +295,7 @@ foldForest f g b fcat forest =
-- | An abstract data type whose values represent
-- 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
= Chart

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

@@ -20,6 +20,7 @@ import Data.List (groupBy)
import PGF.CId
import PGF.Data
import PGF.Tree
import GF.Data.Assoc
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.Data
import PGF.Tree
import PGF.Macros
import PGF.Linearize
@@ -57,17 +58,17 @@ mkRecord typ trm = case (typ,trm) of
str = realize
-- 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
pr (p,vs) = unlines vs
-- 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
pr (p,vs) = p +++ ":" +++ unwords (intersperse "|" (map unlex vs))
-- 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
branches r = case r of
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 _ -> []
-- show record in GF-source-like syntax
recordLinearize :: PGF -> CId -> Tree -> String
recordLinearize :: PGF -> CId -> Expr -> String
recordLinearize pgf lang = prRecord . recLinearize pgf lang
-- 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
typ = case tree of
typ = case expr2tree tree of
Fun f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f
-- show PGF term
termLinearize :: PGF -> CId -> Tree -> String
termLinearize :: PGF -> CId -> Expr -> String
termLinearize pgf lang = show . linTree pgf lang
-- show bracketed markup with references to tree structure
markLinearize :: PGF -> CId -> Tree -> String
markLinearize pgf lang t = concat $ take 1 $ linearizesMark pgf lang t
markLinearize :: PGF -> CId -> Expr -> String
markLinearize pgf lang = concat . take 1 . linearizesMark pgf lang
-- for Morphology: word, lemma, tags
@@ -102,7 +103,7 @@ collectWords pgf lang =
[(f,c,0) | (f,(DTyp [] c _,_,_)) <- Map.toList $ funs $ abstract pgf]
where
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
RR rs -> concat [fromRec f v t | (_,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))
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))
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.Data
import PGF.Tree
import PGF.Linearize
import PGF.Macros (lookValCat)
@@ -28,8 +29,8 @@ import Data.List (intersperse,nub)
import Data.Char (isDigit)
import qualified Text.ParserCombinators.ReadP as RP
visualizeTrees :: PGF -> (Bool,Bool) -> [Tree] -> String
visualizeTrees pgf funscats = unlines . map (prGraph False . tree2graph pgf funscats)
visualizeTrees :: PGF -> (Bool,Bool) -> [Expr] -> String
visualizeTrees pgf funscats = unlines . map (prGraph False . tree2graph pgf funscats . expr2tree)
tree2graph :: PGF -> (Bool,Bool) -> Tree -> [String]
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
-- words are chunks like {[0,1,1,0] old}
alignLinearize :: PGF -> Tree -> String
alignLinearize :: PGF -> Expr -> String
alignLinearize pgf = prGraph True . lin2graph . linsMark where
linsMark t = [s | la <- cncnames pgf, s <- take 1 (linearizesMark pgf la t)]