From be3dc0ef9e9010952f7688cb366d876d01876812 Mon Sep 17 00:00:00 2001 From: krasimir Date: Tue, 8 Sep 2009 08:40:28 +0000 Subject: [PATCH] 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 --- GF.cabal | 4 +- src/GF/Command/Commands.hs | 56 ++++++--------- src/GF/Command/Parse.hs | 1 - src/GF/Command/TreeOperations.hs | 2 +- src/GF/Quiz.hs | 1 - src/GFI.hs | 1 - src/PGF.hs | 75 +++++-------------- src/PGF/Data.hs | 15 ++++ src/PGF/Expr.hs | 102 +------------------------- src/PGF/Expr.hs-boot | 4 +- src/PGF/Generate.hs | 45 ++++++------ src/PGF/Linearize.hs | 13 ++-- src/PGF/Macros.hs | 8 +-- src/PGF/PMCFG.hs | 2 +- src/PGF/Paraphrase.hs | 14 ++-- src/PGF/Parsing/FCFG.hs | 39 ---------- src/PGF/Parsing/FCFG/Active.hs | 5 +- src/PGF/Parsing/FCFG/Incremental.hs | 67 ++++++++++------- src/PGF/Parsing/FCFG/Utilities.hs | 1 + src/PGF/ShowLinearize.hs | 21 +++--- src/PGF/Tree.hs | 107 ++++++++++++++++++++++++++++ src/PGF/Type.hs | 4 -- src/PGF/VisualizeTree.hs | 7 +- 23 files changed, 272 insertions(+), 322 deletions(-) delete mode 100644 src/PGF/Parsing/FCFG.hs create mode 100644 src/PGF/Tree.hs diff --git a/GF.cabal b/GF.cabal index f16c9b298..c40489a14 100644 --- a/GF.cabal +++ b/GF.cabal @@ -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 diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs index 65f64ef11..a660fa55a 100644 --- a/src/GF/Command/Commands.hs +++ b/src/GF/Command/Commands.hs @@ -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 diff --git a/src/GF/Command/Parse.hs b/src/GF/Command/Parse.hs index 35abf1b7b..44366c472 100644 --- a/src/GF/Command/Parse.hs +++ b/src/GF/Command/Parse.hs @@ -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 diff --git a/src/GF/Command/TreeOperations.hs b/src/GF/Command/TreeOperations.hs index 45f927afc..b4fdff5ae 100644 --- a/src/GF/Command/TreeOperations.hs +++ b/src/GF/Command/TreeOperations.hs @@ -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)) ] diff --git a/src/GF/Quiz.hs b/src/GF/Quiz.hs index 43b037b87..ad5f2818c 100644 --- a/src/GF/Quiz.hs +++ b/src/GF/Quiz.hs @@ -20,7 +20,6 @@ module GF.Quiz ( import PGF import PGF.ShowLinearize - import GF.Data.Operations import GF.Infra.UseIO import GF.Infra.Option diff --git a/src/GFI.hs b/src/GFI.hs index 17413e212..654022c72 100644 --- a/src/GFI.hs +++ b/src/GFI.hs @@ -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 diff --git a/src/PGF.hs b/src/PGF.hs index 599b6b47a..ec735da88 100644 --- a/src/PGF.hs +++ b/src/PGF.hs @@ -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) diff --git a/src/PGF/Data.hs b/src/PGF/Data.hs index 6895bd335..50e11f289 100644 --- a/src/PGF/Data.hs +++ b/src/PGF/Data.hs @@ -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 diff --git a/src/PGF/Expr.hs b/src/PGF/Expr.hs index 62a97698a..42f9138c9 100644 --- a/src/PGF/Expr.hs +++ b/src/PGF/Expr.hs @@ -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 diff --git a/src/PGF/Expr.hs-boot b/src/PGF/Expr.hs-boot index 21f5f7ef1..533feea75 100644 --- a/src/PGF/Expr.hs-boot +++ b/src/PGF/Expr.hs-boot @@ -14,4 +14,6 @@ pFactor :: RP.ReadP Expr ppExpr :: Int -> [CId] -> Expr -> PP.Doc -freshName :: CId -> [CId] -> CId \ No newline at end of file +freshName :: CId -> [CId] -> CId + +ppParens :: Bool -> PP.Doc -> PP.Doc diff --git a/src/PGF/Generate.hs b/src/PGF/Generate.hs index 94be66245..5add00a78 100644 --- a/src/PGF/Generate.hs +++ b/src/PGF/Generate.hs @@ -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] --} diff --git a/src/PGF/Linearize.hs b/src/PGF/Linearize.hs index c15bbd105..3ee170640 100644 --- a/src/PGF/Linearize.hs +++ b/src/PGF/Linearize.hs @@ -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) diff --git a/src/PGF/Macros.hs b/src/PGF/Macros.hs index 5d8600090..f6a11799b 100644 --- a/src/PGF/Macros.hs +++ b/src/PGF/Macros.hs @@ -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 [] diff --git a/src/PGF/PMCFG.hs b/src/PGF/PMCFG.hs index 150f74342..480c7d91f 100644 --- a/src/PGF/PMCFG.hs +++ b/src/PGF/PMCFG.hs @@ -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 diff --git a/src/PGF/Paraphrase.hs b/src/PGF/Paraphrase.hs index fecfe34bb..ee615f6ac 100644 --- a/src/PGF/Paraphrase.hs +++ b/src/PGF/Paraphrase.hs @@ -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 diff --git a/src/PGF/Parsing/FCFG.hs b/src/PGF/Parsing/FCFG.hs deleted file mode 100644 index 088c9f480..000000000 --- a/src/PGF/Parsing/FCFG.hs +++ /dev/null @@ -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 diff --git a/src/PGF/Parsing/FCFG/Active.hs b/src/PGF/Parsing/FCFG/Active.hs index 07fa1ba4f..e88926f6e 100644 --- a/src/PGF/Parsing/FCFG/Active.hs +++ b/src/PGF/Parsing/FCFG/Active.hs @@ -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) diff --git a/src/PGF/Parsing/FCFG/Incremental.hs b/src/PGF/Parsing/FCFG/Incremental.hs index 0aedd6d30..dbc738a05 100644 --- a/src/PGF/Parsing/FCFG/Incremental.hs +++ b/src/PGF/Parsing/FCFG/Incremental.hs @@ -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 diff --git a/src/PGF/Parsing/FCFG/Utilities.hs b/src/PGF/Parsing/FCFG/Utilities.hs index 6a2c13c0a..dc0b2dc4a 100644 --- a/src/PGF/Parsing/FCFG/Utilities.hs +++ b/src/PGF/Parsing/FCFG/Utilities.hs @@ -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) diff --git a/src/PGF/ShowLinearize.hs b/src/PGF/ShowLinearize.hs index 62329eb88..274b534dd 100644 --- a/src/PGF/ShowLinearize.hs +++ b/src/PGF/ShowLinearize.hs @@ -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] diff --git a/src/PGF/Tree.hs b/src/PGF/Tree.hs new file mode 100644 index 000000000..94802e70b --- /dev/null +++ b/src/PGF/Tree.hs @@ -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 diff --git a/src/PGF/Type.hs b/src/PGF/Type.hs index 5ddad6ef0..34aaeaf7b 100644 --- a/src/PGF/Type.hs +++ b/src/PGF/Type.hs @@ -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 diff --git a/src/PGF/VisualizeTree.hs b/src/PGF/VisualizeTree.hs index 4e8df64c0..8871e9f84 100644 --- a/src/PGF/VisualizeTree.hs +++ b/src/PGF/VisualizeTree.hs @@ -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)]