From 4e80f9eceb1bb4cdba4a9fcc08d759183a925ff2 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Tue, 15 Sep 2026 08:48:55 +0200 Subject: [PATCH] extend the backwards compatibility module PGF --- src/runtime/haskell/PGF.hs | 637 +++++++++++++++++++++++++++++++++++ src/runtime/haskell/PGF.hsc | 116 ------- src/runtime/haskell/PGF2.hsc | 302 ++++------------- 3 files changed, 709 insertions(+), 346 deletions(-) create mode 100644 src/runtime/haskell/PGF.hs delete mode 100644 src/runtime/haskell/PGF.hsc diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs new file mode 100644 index 000000000..bb5b9100a --- /dev/null +++ b/src/runtime/haskell/PGF.hs @@ -0,0 +1,637 @@ +{-# LANGUAGE BangPatterns #-} +------------------------------------------------- +-- | +-- Module : PGF +-- Maintainer : Krasimir Angelov +-- Stability : stable +-- Portability : portable +-- +-- This module is an Application Programming Interface to +-- load and interpret grammars compiled in Portable Grammar Format (PGF). +-- The PGF format is produced as a final output from the GF compiler. +-- The API is meant to be used for embedding GF grammars in Haskell +-- programs +------------------------------------------------- + +module PGF( + -- * PGF + PGF, + readPGF, + + -- * Identifiers + CId, mkCId, wildCId, + showCId, readCId, + -- extra + ppCId, PGF2.pIdent, + + -- * Languages + Language, + showLanguage, readLanguage, + languages, abstractName, languageCode, + + -- * Types + Type, Hypo, BindType(..), + PGF2.showType, PGF2.readType, + PGF2.mkType, PGF2.mkHypo, PGF2.mkDepHypo, PGF2.mkImplHypo, + PGF2.unType, + categories, categoryContext, PGF2.startCat, + + -- * Functions + PGF2.functions, PGF2.functionsByCat, PGF2.functionType, + + -- * Expressions & Trees + -- ** Tree + Tree, + + -- ** Expr + Expr, + PGF2.showExpr, PGF2.readExpr, PGF2.pExpr, + mkAbs, unAbs, + mkApp, unApp, PGF2.unapply, + PGF2.mkStr, PGF2.unStr, + PGF2.mkInt, PGF2.unInt, + PGF2.mkDouble, PGF2.unDouble, + PGF2.mkFloat, PGF2.unFloat, + PGF2.mkMeta, PGF2.unMeta, + -- extra + PGF2.exprSize, PGF2.exprFunctions, + + -- * Operations + -- ** Linearization + linearize, linearizeAllLang, linearizeAll, bracketedLinearize, {-bracketedLinearizeAll,-} tabularLinearizes, + showPrintName, + + BracketedString(..), FId, LIndex, Token, + showBracketedString,flattenBracketedString, + + -- ** Parsing + parse, parseAllLang, parseAll, complete, + + -- ** Evaluation + {- PGF.compute, paraphrase,-} + + -- ** Type Checking + -- | The type checker in PGF does both type checking and renaming + -- i.e. it verifies that all identifiers are declared and it + -- distinguishes between global function or type indentifiers and + -- variable names. The type checker should always be applied on + -- expressions entered by the user i.e. those produced via functions + -- like 'readType' and 'readExpr' because otherwise unexpected results + -- could appear. All typechecking functions returns updated versions + -- of the input types or expressions because the typechecking could + -- also lead to metavariables instantiations. + PGF2.checkType, PGF2.checkExpr, PGF2.inferExpr, + + -- ** Generation + -- | The PGF interpreter allows automatic generation of + -- abstract syntax expressions of a given type. Since the + -- type system of GF allows dependent types, the generation + -- is in general undecidable. In fact, the set of all type + -- signatures in the grammar is equivalent to a Turing-complete language (Prolog). + -- + -- There are several generation methods which mainly differ in: + -- + -- * whether the expressions are sequentially or randomly generated? + -- + -- * are they generated from a template? The template is an expression + -- containing meta variables which the generator will fill in. + -- + -- * is there a limit of the depth of the expression? + -- The depth can be used to limit the search space, which + -- in some cases is the only way to make the search decidable. + generateAll, generateAllDepth, + {-generateFrom, generateFromDepth,-} + generateRandom, generateRandomDepth, + {-generateRandomFrom, generateRandomFromDepth,-} + + -- ** Morphological Analysis + Lemma, Analysis, Morpho, + lookupMorpho, buildMorpho, fullFormLexicon, + + -- ** Visualizations + graphvizAbstractTree, + graphvizParseTree, + graphvizParseTreeDep, + graphvizDependencyTree, + graphvizBracketedString, + graphvizAlignment, + gizaAlignment, + GraphvizOptions(..), + PGF2.graphvizDefaults, + -- extra: + Labels, getDepLabels, + CncLabels, getCncDepLabels, + + ) where + +import Prelude hiding ((<>)) +import PGF2 (PGF, GraphvizOptions(..), FId, Expr(..), Type(..), Hypo, BindType(..)) +import qualified PGF2 +import qualified Data.Map as Map +import Control.Monad +import Data.Char +import Data.Maybe (fromMaybe) +import Data.List (nub,intersperse,groupBy,sortBy,partition) +import Data.Ord (comparing) +import qualified Text.ParserCombinators.ReadP as RP +import Text.PrettyPrint +import System.Random + +--------------------------------------------------- +-- Interface +--------------------------------------------------- + +newtype CId = CId String deriving (Eq,Ord) + +mkCId = CId +wildCId = CId "_" + +-- | Reads an identifier from 'String'. The function returns 'Nothing' if the string is not valid identifier. +readCId :: String -> Maybe CId +readCId s = case [x | (x,cs) <- RP.readP_to_S pCId s, all isSpace cs] of + [x] -> Just x + _ -> Nothing + +-- | Renders the identifier as 'String' +showCId :: CId -> String +showCId (CId raw) = PGF2.showIdent raw + +instance Show CId where + showsPrec _ = showString . showCId + +instance Read CId where + readsPrec _ = RP.readP_to_S pCId + +pCId :: RP.ReadP CId +pCId = do s <- PGF2.pIdent + if s == "_" + then RP.pfail + else return (mkCId s) + +ppCId :: CId -> Doc +ppCId = text . showCId + +type Language = CId + +readLanguage lang = CId lang +showLanguage (CId lang) = lang + +type Tree = Expr + +mkAbs :: BindType -> CId -> Expr -> Expr +mkAbs bt (CId var) e = PGF2.mkAbs bt var e + +unAbs :: Expr -> Maybe (BindType, CId, Expr) +unAbs e = + case PGF2.unAbs e of + Just (bt,var,e) -> Just (bt,CId var,e) + Nothing -> Nothing + +mkApp :: CId -> [Expr] -> Expr +mkApp (CId fun) es = PGF2.mkApp fun es + +unApp :: Expr -> Maybe (CId, [Expr]) +unApp e = + case PGF2.unApp e of + Just (fun,es) -> Just (CId fun,es) + Nothing -> Nothing + +-- | Reads file in Portable Grammar Format and produces +-- 'PGF' structure. The file is usually produced with: +-- +-- > $ gf -make +readPGF :: FilePath -> IO PGF +readPGF = PGF2.readPGF + +-- | Tries to parse the given string in the specified language +-- and to produce abstract syntax expression. +parse :: PGF -> Language -> Type -> String -> [Tree] +parse gr (CId lang) cat sent = + case Map.lookup lang (PGF2.languages gr) of + Just cnc -> case PGF2.parse cnc cat sent of + PGF2.ParseOk ts -> map fst ts + _ -> [] + Nothing -> error ("Unknown language: " ++ lang) + +-- | The same as 'parseAllLang' but does not return +-- the language. +parseAll :: PGF -> Type -> String -> [[Tree]] +parseAll gr cat sent = + [map fst ts | (lang,cnc) <- Map.toList (PGF2.languages gr) + , PGF2.ParseOk ts <- [PGF2.parse cnc cat sent]] + +-- | Tries to parse the given string with all available languages. +-- The returned list contains pairs of language +-- and list of abstract syntax expressions +-- (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])] +parseAllLang gr cat sent = + [(CId lang,map fst ts) + | (lang,cnc) <- Map.toList (PGF2.languages gr) + , PGF2.ParseOk ts <- [PGF2.parse cnc cat sent]] + +complete :: PGF -> Language -> Type -> String -> String -> (BracketedString,String,Map.Map Token [CId]) +complete pgf (CId lang) typ input prefix = + case Map.lookup lang (PGF2.languages pgf) of + Just cnc -> case PGF2.complete cnc typ input prefix of + PGF2.ParseOk res -> (noBS, input++" "++prefix, Map.fromListWith (++) [(w,[CId fun]) | (w,fun,cat,_) <- res]) + _ -> (noBS, input++" "++prefix, Map.empty) + Nothing -> error ("Unknown language: " ++ lang) + where + noBS = error "TODO: The bracketed string is not computed" + +linearize :: PGF -> Language -> Tree -> String +linearize pgf (CId lang) t = + case Map.lookup lang (PGF2.languages pgf) of + Just cnc -> PGF2.linearize cnc t + Nothing -> error ("Unknown language: " ++ lang) + +-- | The same as 'linearizeAllLang' but does not return +-- the language. +linearizeAll :: PGF -> Tree -> [String] +linearizeAll pgf = map snd . linearizeAllLang pgf + +-- | Linearizes given expression as string in all languages +-- available in the grammar. +linearizeAllLang :: PGF -> Tree -> [(Language,String)] +linearizeAllLang pgf t = [(CId lang,PGF2.linearize cnc t) | (lang,cnc) <- Map.toList (PGF2.languages pgf)] + +-- | Linearizes given expression as a bracketed string in the language +bracketedLinearize :: PGF -> Language -> Tree -> [BracketedString] +bracketedLinearize pgf (CId lang) t = + case Map.lookup lang (PGF2.languages pgf) of + Just cnc -> map bs2bs (PGF2.bracketedLinearize cnc t) + Nothing -> error ("Unknown language: " ++ lang) + +-- | Creates a table from feature name to linearization. +-- The outher list encodes the variations +tabularLinearizes :: PGF -> Language -> Expr -> [[(String,String)]] +tabularLinearizes pgf (CId lang) t = + case Map.lookup lang (PGF2.languages pgf) of + Just cnc -> [PGF2.tabularLinearize cnc t] + Nothing -> error ("Unknown language: " ++ lang) + +showPrintName :: PGF -> Language -> CId -> String +showPrintName gr (CId lang) (CId name) = + case Map.lookup lang (PGF2.languages gr) of + Just cnc -> fromMaybe name (PGF2.printName cnc name) + Nothing -> error ("Unknown language: " ++ lang) + +-- | List of all languages available in the given grammar. +languages :: PGF -> [Language] +languages gr = [CId lang | (lang,_) <- Map.toList (PGF2.languages gr)] + +-- | Gets the RFC 4646 language tag +-- of the language which the given concrete syntax implements, +-- if this is listed in the source grammar. +-- Example language tags include @\"en\"@ for English, +-- and @\"en-UK\"@ for British English. +languageCode :: PGF -> Language -> Maybe String +languageCode gr (CId lang) = + case Map.lookup lang (PGF2.languages gr) of + Just cnc -> PGF2.languageCode cnc + _ -> Nothing + +-- | The abstract language name is the name of the top-level +-- abstract module +abstractName :: PGF -> Language +abstractName gr = CId (PGF2.abstractName gr) + +-- | List of all categories defined in the given grammar. +-- The categories are defined in the abstract syntax +-- with the \'cat\' keyword. +categories :: PGF -> [CId] +categories gr = map CId (PGF2.categories gr) + +categoryContext :: PGF -> CId -> Maybe [Hypo] +categoryContext gr (CId cat) = PGF2.categoryContext gr cat + +-- | List of all functions defined in the abstract syntax +functions :: PGF -> [CId] +functions gr = map CId (PGF2.functions gr) + +-- | List of all functions defined for a given category +functionsByCat :: PGF -> CId -> [CId] +functionsByCat gr (CId fun) = map CId (PGF2.functionsByCat gr fun) + +-- | The type of a given function +functionType :: PGF -> CId -> Maybe Type +functionType gr (CId fun) = PGF2.functionType gr fun + +type LIndex= String +type Token = String + +-- | BracketedString represents a sentence that is linearized +-- as usual but we also want to retain the ''brackets'' that +-- mark the beginning and the end of each constituent. +data BracketedString + = Leaf Token -- ^ this is the leaf i.e. a single token + | Bracket CId {-# UNPACK #-} !FId {-# UNPACK #-} !FId LIndex CId [Expr] [BracketedString] + -- ^ this is a bracket. The 'CId' is the category of + -- the phrase. The 'FId' is an unique identifier for + -- every phrase in the sentence. For context-free grammars + -- i.e. without discontinuous constituents this identifier + -- is also unique for every bracket. When there are discontinuous + -- phrases then the identifiers are unique for every phrase but + -- not for every bracket since the bracket represents a constituent. + -- The different constituents could still be distinguished by using + -- the constituent index i.e. 'LIndex'. If the grammar is reduplicating + -- then the constituent indices will be the same for all brackets + -- that represents the same constituent. + +bs2bs (PGF2.Leaf token) = Leaf token +bs2bs PGF2.BIND = Leaf "&+" +bs2bs (PGF2.Bracket cat fid lbl fun bs) = Bracket (CId cat) fid fid lbl (CId fun) [] (map bs2bs bs) + +-- | Renders the bracketed string as string where +-- the brackets are shown as @(S ...)@ where +-- @S@ is the category. +showBracketedString :: BracketedString -> String +showBracketedString = render . ppBracketedString + +ppBracketedString (Leaf t) = text t +ppBracketedString (Bracket cat fid fid' index _ _ bss) = parens (ppCId cat <> colon <> int fid <+> hsep (map ppBracketedString bss)) + +flattenBracketedString :: BracketedString -> [String] +flattenBracketedString (Leaf w) = [w] +flattenBracketedString (Bracket _ _ _ _ _ _ bss) = concatMap flattenBracketedString bss + +-- | Renders abstract syntax tree in Graphviz format. +-- The pair of 'Bool' @(funs,cats)@ lets you control whether function names and +-- category names are included in the rendered tree +graphvizAbstractTree :: PGF -> (Bool,Bool) -> Tree -> String +graphvizAbstractTree gr (funs,cats) = PGF2.graphvizAbstractTree gr PGF2.graphvizDefaults{noFun=not funs,noCat=not cats} + +graphvizParseTree :: PGF -> Language -> GraphvizOptions -> Tree -> String +graphvizParseTree gr (CId lang) opts t = + case Map.lookup lang (PGF2.languages gr) of + Just cnc -> PGF2.graphvizParseTree cnc opts t + Nothing -> error ("Unknown language: " ++ lang) + +type Labels = Map.Map CId [String] +type CncLabels = [CncLabel] + +data CncLabel = + CncSyncat (String, String -> Maybe (String -> String,String,String)) + -- (fun, word/lemma -> (pos,label,target)) + -- the pos can remain unchanged, as in the current notation in the article + | CncMorpho (String,[String]) + -- (category, features in ascending order) + | CncForm (String,(String,String)) + -- (wordform, (lemma,features)) + +-- | Prepare lines obtained from a configuration file for labels for +-- use with 'graphvizDependencyTree'. Format per line /fun/ /label/@*@. +--- ignore other gf-ud annotatations than #fun and #cat at this point +getDepLabels :: String -> Labels +getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map (words . rmcomments) (lines s), not (head f == '#')] + +getCncDepLabels :: String -> CncLabels +getCncDepLabels s = wlabels ws ++ flabels fs + where + wlabels = + map CncSyncat . + map merge . + groupBy (\ (x,_) (a,_) -> x == a) . + sortBy (comparing fst) . + concatMap analyse . + filter chooseW + + flabels = + map CncMorpho . + map collectTags . + map words + + (fs,ws) = partition chooseF $ map uncomment $ lines s + + --- choose is for compatibility with the general notation + chooseW line = notElem '(' line && + elem '{' line + --- ignoring non-local (with "(") and abstract (without "{") rules + ---- TODO: this means that "(" cannot be a token + + chooseF line = take 1 line == "@" --- feature assignments have the form e.g. @N SgNom SgGen ; no spaces inside tags + + uncomment line = case line of + '-':'-':_ -> "" + c:cs -> c : uncomment cs + _ -> line + + analyse line = case break (=='{') line of + (beg,_:ws) -> case break (=='}') ws of + (toks,_:target) -> case (getToks beg, words target) of + (funs,[ label,j]) -> [(fun, (tok, (id, label,j))) | fun <- funs, tok <- getToks toks] + (funs,[pos,label,j]) -> [(fun, (tok, (const pos,label,j))) | fun <- funs, tok <- getToks toks] + _ -> [] + _ -> [] + _ -> [] + merge rules@((fun,_):_) = (fun, \tok -> + case lookup tok (map snd rules) of + Just new -> return new + _ -> lookup "*" (map snd rules) + ) + getToks = map unquote . filter (/=",") . toks + toks s = case lex s of [(t,"")] -> [t] ; [(t,cc)] -> t:toks cc ; _ -> [] + unquote s = case s of '"':cc@(_:_) | last cc == '"' -> init cc ; _ -> s + + collectTags (w:ws) = (tail w,ws) + +-- auxiliaries for UD conversion PK 15/12/2018 +rmcomments :: String -> String +rmcomments s = case s of + '-':'-':_ -> [] + '#':'f':'u':'n':rest -> rmcomments rest -- the new gf-ud format + '#':'c':'a':'t':rest -> rmcomments rest + x:xs -> x : rmcomments xs + _ -> [] + +-- | Visualize word dependency tree. +graphvizDependencyTree + :: String -- ^ Output format: @"latex"@, @"conll"@, @"malt_tab"@, @"malt_input"@ or @"dot"@ + -> Bool -- ^ Include extra information (debug) + -> Maybe Labels -- ^ abstract label information obtained with 'getDepLabels' + -> Maybe CncLabels -- ^ concrete label information obtained with ' ' (was: unused (was: @Maybe String@)) + -> PGF + -> CId -- ^ The language of analysis + -> Tree + -> String -- ^ Rendered output in the specified format +graphvizDependencyTree format debug mb_labels mb_cnclabels gr (CId lang) t = + error "TODO: graphvizDependencyTree" + +graphvizParseTreeDep :: Maybe Labels -> PGF -> Language -> GraphvizOptions -> Tree -> String +graphvizParseTreeDep mbl pgf lang opts tree = graphvizBracketedString opts mbl tree $ bracketedLinearize pgf lang tree + +graphvizBracketedString :: GraphvizOptions -> Maybe Labels -> Tree -> [BracketedString] -> String +graphvizBracketedString opts mbl tree bss = render graphviz_code + where + graphviz_code + = text "graph {" $$ + text node_style $$ + vcat internal_nodes $$ + (if noLeaves opts then empty + else text leaf_style $$ + leaf_nodes + ) $$ text "}" + + leaf_style = mkOption "edge" "style" (leafEdgeStyle opts) ++ + mkOption "edge" "color" (leafColor opts) ++ + mkOption "node" "fontcolor" (leafColor opts) ++ + mkOption "node" "fontname" (leafFont opts) ++ + mkOption "node" "shape" "plaintext" + + node_style = mkOption "edge" "style" (nodeEdgeStyle opts) ++ + mkOption "edge" "color" (nodeColor opts) ++ + mkOption "node" "fontcolor" (nodeColor opts) ++ + mkOption "node" "fontname" (nodeFont opts) ++ + mkOption "node" "shape" nodeshape + where nodeshape | noFun opts && noCat opts = "point" + | otherwise = "plaintext" + + mkOption object optname optvalue + | null optvalue = "" + | otherwise = object ++ "[" ++ optname ++ "=\"" ++ optvalue ++ "\"]; " + + mkNode fun cat + | noFun opts = showCId cat + | noCat opts = showCId fun + | otherwise = showCId fun ++ " : " ++ showCId cat + + nil = -1 + internal_nodes = [mkLevel internals | + internals <- getInternals (map ((,) nil) bss), + not (null internals)] + leaf_nodes = mkLevel [(parent, id, mkLeafNode cat word) | + (id, (parent, (cat,word))) <- zip [100000..] (concatMap (getLeaves (mkCId "?") nil) bss)] + + getInternals [] = [] + getInternals nodes + = nub [(parent, fid, mkNode fun cat) | + (parent, Bracket cat fid _ _ fun _ _) <- nodes] + : getInternals [(fid, child) | + (_, Bracket _ fid _ _ _ _ children) <- nodes, + child <- children] + + getLeaves cat parent (Leaf word) = [(parent, (cat, word))] -- the lowest cat before the word + getLeaves _ parent (Bracket cat fid _ i _ _ children) + = concatMap (getLeaves cat fid) children + + mkLevel nodes + = text "subgraph {rank=same;" $$ + nest 2 (-- the following gives the name of the node and its label: + vcat [tag id <> text (mkOption "" "label" lbl) | (_, id, lbl) <- nodes] $$ + -- the following is for fixing the order between the children: + (if length nodes > 1 then + text (mkOption "edge" "style" "invis") $$ + hsep (intersperse (text " -- ") [tag id | (_, id, _) <- nodes]) <+> semi + else empty) + ) $$ + text "}" $$ + -- the following is for the edges between parent and children: + vcat [tag pid <> text " -- " <> tag id <> text (depLabel node) | node@(pid, id, _) <- nodes, pid /= nil] $$ + space + + depLabel node@(parent,id,lbl) + | noDep opts = ";" + | otherwise = case getArg id of + Just (fun,arg) -> mkOption "" "label" (lookLabel fun arg) + _ -> ";" + getArg i = getArgumentPlace i (expr2numtree tree) Nothing + + labels = maybe Map.empty id mbl + + lookLabel fun arg = case Map.lookup fun labels of + Just xx | length xx > arg -> case xx !! arg of + "head" -> "" + l -> l + _ -> argLabel fun arg + argLabel fun arg = if arg==0 then "" else "dep#" ++ show arg --showCId fun ++ "#" ++ show arg + -- assuming the arg is head, if no configuration is given; always true for 1-arg funs + mkLeafNode cat word + | noDep opts = word --- || not (noCat opts) -- show POS only if intermediate nodes hidden + | otherwise = posCat cat ++ "\n" ++ word -- show POS in dependency tree + + posCat cat = case Map.lookup cat labels of + Just [p] -> p + _ -> showCId cat + +---- to restore the argument place from bracketed linearization +data NumTree = NumTree Int CId [NumTree] + +getArgumentPlace :: Int -> NumTree -> Maybe (CId,Int) -> Maybe (CId,Int) +getArgumentPlace i tree@(NumTree int fun ts) mfi + | i == int = mfi + | otherwise = case [fj | (t,x) <- zip ts [0..], Just fj <- [getArgumentPlace i t (Just (fun,x))]] of + fj:_ -> Just fj + _ -> Nothing + +expr2numtree :: Expr -> NumTree +expr2numtree = fst . renumber 0 . flatten where + flatten e = case e of + EApp f a -> case flatten f of + NumTree _ g ts -> NumTree 0 g (ts ++ [flatten a]) + EFun f -> NumTree 0 (CId f) [] + renumber i t@(NumTree _ f ts) = case renumbers i ts of + (ts',j) -> (NumTree j f ts', j+1) + renumbers i ts = case ts of + t:tt -> case renumber i t of + (t',j) -> case renumbers j tt of (tt',k) -> (t':tt',k) + _ -> ([],i) +----- end this terrible stuff AR 4/11/2015 + +-- alignment in the Graphviz format from the intermediate structure +-- same effect as the old direct function +graphvizAlignment :: PGF -> [Language] -> Expr -> String +graphvizAlignment pgf langs exp = + let cncs = [cnc | (l,cnc) <- Map.toList (PGF2.languages pgf) + , CId l `elem` langs] + in PGF2.graphvizWordAlignment cncs PGF2.graphvizDefaults exp + +gizaAlignment :: PGF -> (Language,Language) -> Expr -> (String,String,String) +gizaAlignment = error "TODO: gizaAlignment" + + +tag i + | i < 0 = char 'r' <> int (negate i) + | otherwise = char 'n' <> int i + +-- | Generates an exhaustive possibly infinite list of +-- abstract syntax expressions. +generateAll :: PGF -> Type -> [Expr] +generateAll pgf ty = map fst (PGF2.generateAll pgf ty) + +-- | A variant of 'generateAll' which also takes as argument +-- the upper limit of the depth of the generated expression. +generateAllDepth :: PGF -> Type -> Maybe Int -> [Expr] +generateAllDepth pgf ty mb_dp = map fst (PGF2.generateAllDepth pgf ty (fromMaybe maxBound mb_dp)) + +-- | 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 :: RandomGen g => g -> PGF -> Type -> [Expr] +generateRandom g pgf ty = map fst (PGF2.generateRandom g pgf ty) + +-- | A variant of 'generateRandom' which also takes as argument +-- the upper limit of the depth of the generated expression. +generateRandomDepth :: RandomGen g => g -> PGF -> Type -> Maybe Int -> [Expr] +generateRandomDepth g pgf ty mb_dp = map fst (PGF2.generateRandomDepth g pgf ty (fromMaybe maxBound mb_dp)) + +type Lemma = CId +type Analysis = String + +newtype Morpho = Morpho PGF2.Concr + +buildMorpho :: PGF -> Language -> Morpho +buildMorpho pgf (CId lang) = Morpho $ + case Map.lookup lang (PGF2.languages pgf) of + Just cnc -> cnc + Nothing -> error ("Unknown language: " ++ lang) + +lookupMorpho :: Morpho -> String -> [(Lemma,Analysis)] +lookupMorpho (Morpho cnc) s = + [(CId fun,an) | (fun,an,_) <- PGF2.lookupMorpho cnc s] + +fullFormLexicon :: Morpho -> [(String,[(Lemma,Analysis)])] +fullFormLexicon (Morpho cnc) = + [(w,[(CId fun,an) | (fun,an,_) <- ans]) | (w,ans) <- PGF2.fullFormLexicon cnc] diff --git a/src/runtime/haskell/PGF.hsc b/src/runtime/haskell/PGF.hsc deleted file mode 100644 index 745473649..000000000 --- a/src/runtime/haskell/PGF.hsc +++ /dev/null @@ -1,116 +0,0 @@ -module PGF ( PGF2.PGF, readPGF - , abstractName - - , CId, mkCId, wildCId, showCId, readCId, pIdent - - , PGF2.categories, PGF2.categoryContext, PGF2.startCat - , functions, functionsByCat - - , PGF2.Expr(..), PGF2.Literal(..), Tree - , PGF2.readExpr, PGF2.showExpr, pExpr - , PGF2.mkAbs, PGF2.unAbs - , PGF2.mkApp, PGF2.unApp, PGF2.unapply - , PGF2.mkStr, PGF2.unStr - , PGF2.mkInt, PGF2.unInt - , PGF2.mkDouble, PGF2.unDouble - , PGF2.mkFloat, PGF2.unFloat - , PGF2.mkMeta, PGF2.unMeta - , PGF2.exprSize, PGF2.exprFunctions - - , PGF2.Type(..), PGF2.Hypo - , PGF2.readType, PGF2.showType - , PGF2.mkType, PGF2.unType - , PGF2.mkHypo, PGF2.mkDepHypo, PGF2.mkImplHypo - - , PGF2.PGFError(..) - ) where - -import PGF2.FFI - -import Foreign -import Foreign.C -import Control.Exception(mask_) -import Control.Monad -import qualified PGF2 as PGF2 -import qualified Text.ParserCombinators.ReadP as RP -import System.IO.Unsafe(unsafePerformIO) - -#include - -newtype CId = CId String deriving (Show,Read,Eq,Ord) - -type Language = CId - -readPGF = PGF2.readPGF - - -readLanguage = readCId -showLanguage (CId s) = s - - -abstractName gr = CId (PGF2.abstractName gr) - - -categories gr = map CId (PGF2.categories gr) - - -functions gr = map CId (PGF2.functions gr) -functionsByCat gr (CId c) = map CId (PGF2.functionsByCat gr c) - -type Tree = PGF2.Expr - - -mkCId x = CId x -wildCId = CId "_" -showCId (CId x) = x -readCId s = Just (CId s) - - -pIdent :: RP.ReadP String -pIdent = - liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest) - `mplus` - do RP.char '\'' - cs <- RP.many1 insideChar - RP.char '\'' - return cs --- where -insideChar = RP.readS_to_P $ \s -> - case s of - [] -> [] - ('\\':'\\':cs) -> [('\\',cs)] - ('\\':'\'':cs) -> [('\'',cs)] - ('\\':cs) -> [] - ('\'':cs) -> [] - (c:cs) -> [(c,cs)] - -isIdentFirst c = - (c == '_') || - (c >= 'a' && c <= 'z') || - (c >= 'A' && c <= 'Z') || - (c >= '\192' && c <= '\255' && c /= '\247' && c /= '\215') -isIdentRest c = - (c == '_') || - (c == '\'') || - (c >= '0' && c <= '9') || - (c >= 'a' && c <= 'z') || - (c >= 'A' && c <= 'Z') || - (c >= '\192' && c <= '\255' && c /= '\247' && c /= '\215') - -pExpr :: RP.ReadP PGF2.Expr -pExpr = - RP.readS_to_P $ \str -> - unsafePerformIO $ - withText str $ \c_str -> - alloca $ \c_pos -> - mask_ $ do - c_expr <- pgf_read_expr_ex c_str c_pos unmarshaller - if c_expr == castPtrToStablePtr nullPtr - then return [] - else do expr <- deRefStablePtr c_expr - freeStablePtr c_expr - pos <- peek c_pos - size <- ((#peek PgfText, size) c_str) :: IO CSize - let c_text = castPtr c_str `plusPtr` (#offset PgfText, text) - s <- peekUtf8CString pos (c_text `plusPtr` fromIntegral size) - return [(expr,s)] diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index a1378c5e9..5444b1c8f 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/src/runtime/haskell/PGF2.hsc @@ -32,7 +32,7 @@ module PGF2 (-- * PGF functionType, functionIsConstructor, functionProbability, -- ** Expressions - Expr(..), Literal(..), showExpr, readExpr, + Expr(..), Literal(..), showExpr, showIdent, readExpr, pExpr, pIdent, mkAbs, unAbs, Var, mkApp, unApp, unapply, mkVar, unVar, @@ -71,8 +71,6 @@ module PGF2 (-- * PGF -- ** Visualizations GraphvizOptions(..), graphvizDefaults, graphvizAbstractTree, graphvizParseTree, - Labels, getDepLabels, - graphvizDependencyTree, conlls2latexDoc, getCncDepLabels, graphvizWordAlignment, -- * Concrete syntax @@ -83,7 +81,7 @@ module PGF2 (-- * PGF FId, BracketedString(..), showBracketedString, flattenBracketedString, bracketedLinearize, bracketedLinearizeAll, hasLinearization, categoryFields, - printName, alignWords, gizaAlignment, + printName, alignWords, -- ** Parsing ParseOutput(..), parse, robustParse, parseWithHeuristics, complete, @@ -102,7 +100,7 @@ import PGF2.FFI import Foreign import Foreign.C -import Control.Monad(forM,forM_) +import Control.Monad(forM,forM_,liftM2,mplus) import Control.Exception(bracket,mask_,throwIO) import System.IO.Unsafe(unsafePerformIO, unsafeInterleaveIO) import System.Random @@ -112,6 +110,7 @@ import Data.List(intersperse,groupBy) import Data.Char(isUpper,isSpace,isPunctuation) import Data.Maybe(maybe) import Text.PrettyPrint +import qualified Text.ParserCombinators.ReadP as RP #ifdef __linux__ #define _GNU_SOURCE @@ -119,7 +118,10 @@ import Text.PrettyPrint #endif #include --- | Reads a PGF file and keeps it in memory. +-- | Reads a file in a Portable Grammar Format and produces +-- a 'PGF' structure. The file is usually produced with: +-- +-- > $ gf -make readPGF :: FilePath -> IO PGF readPGF fpath = readPGFWithProbs fpath Nothing @@ -661,8 +663,6 @@ alignWords c e = unsafePerformIO $ free ptr return (phrase, map fromIntegral fids) -gizaAlignment = error "TODO: gizaAlignment" - ----------------------------------------------------------------------------- -- Functions using Concr -- Morpho analyses, parsing & linearization @@ -1477,228 +1477,6 @@ graphvizWordAlignment cs opts e = then return "" else peekText c_text -type Labels = Map.Map Fun [String] - -getDepLabels :: String -> Labels -getDepLabels s = Map.fromList [(f,ls) | f:ls <- map words (lines s)] - --- | Visualize word dependency tree. -graphvizDependencyTree - :: String -- ^ Output format: @"latex"@, @"conll"@, @"malt_tab"@, @"malt_input"@ or @"dot"@ - -> Bool -- ^ Include extra information (debug) - -> Maybe Labels -- ^ abstract label information obtained with 'getDepLabels' - -> Maybe CncLabels -- ^ concrete label information obtained with ' ' (was: unused (was: @Maybe String@)) - -> Concr - -> Expr - -> String -- ^ Rendered output in the specified format -graphvizDependencyTree format debug mlab mclab concr t = error "TODO: graphvizDependencyTree" - ----------------------- should be a separate module? - --- visualization with latex output. AR Nov 2015 - -conlls2latexDoc :: [String] -> String -conlls2latexDoc = - render . - latexDoc . - vcat . - intersperse (text "" $+$ app "vspace" (text "4mm")) . - map conll2latex . - filter (not . null) - -conll2latex :: String -> Doc -conll2latex = ppLaTeX . conll2latex' . parseCoNLL - -conll2latex' :: CoNLL -> [LaTeX] -conll2latex' = dep2latex . conll2dep' - -data Dep = Dep { - wordLength :: Int -> Double -- length of word at position int -- was: fixed width, millimetres (>= 20.0) - , tokens :: [(String,String)] -- word, pos (0..) - , deps :: [((Int,Int),String)] -- from, to, label - , root :: Int -- root word position - } - --- some general measures -defaultWordLength = 20.0 -- the default fixed width word length, making word 100 units -defaultUnit = 0.2 -- unit in latex pictures, 0.2 millimetres -spaceLength = 10.0 -charWidth = 1.8 - -wsize rwld w = 100 * rwld w + spaceLength -- word length, units -wpos rwld i = sum [wsize rwld j | j <- [0..i-1]] -- start position of the i'th word -wdist rwld x y = sum [wsize rwld i | i <- [min x y .. max x y - 1]] -- distance between words x and y -labelheight h = h + arcbase + 3 -- label just above arc; 25 would put it just below -labelstart c = c - 15.0 -- label starts 15u left of arc centre -arcbase = 30.0 -- arcs start and end 40u above the bottom -arcfactor r = r * 600 -- reduction of arc size from word distance -xyratio = 3 -- width/height ratio of arcs - -putArc :: (Int -> Double) -> Int -> Int -> Int -> String -> [DrawingCommand] -putArc frwld height x y label = [oval,arrowhead,labelling] where - oval = Put (ctr,arcbase) (OvalTop (wdth,hght)) - arrowhead = Put (endp,arcbase + 5) (ArrowDown 5) -- downgoing arrow 5u above the arc base - labelling = Put (labelstart ctr,labelheight (hght/2)) (TinyText label) - dxy = wdist frwld x y -- distance between words, >>= 20.0 - ndxy = 100 * rwld * fromIntegral height -- distance that is indep of word length - hdxy = dxy / 2 -- half the distance - wdth = dxy - (arcfactor rwld)/dxy -- longer arcs are wider in proportion - hght = ndxy / (xyratio * rwld) -- arc height is independent of word length - begp = min x y -- begin position of oval - ctr = wpos frwld begp + hdxy + (if x < y then 20 else 10) -- LR arcs are farther right from center of oval - endp = (if x < y then (+) else (-)) ctr (wdth/2) -- the point of the arrow - rwld = 0.5 ---- - -dep2latex :: Dep -> [LaTeX] -dep2latex d = - [Comment (unwords (map fst (tokens d))), - Picture defaultUnit (width,height) ( - [Put (wpos rwld i,0) (Text w) | (i,w) <- zip [0..] (map fst (tokens d))] -- words - ++ [Put (wpos rwld i,15) (TinyText w) | (i,w) <- zip [0..] (map snd (tokens d))] -- pos tags 15u above bottom - ++ concat [putArc rwld (aheight x y) x y label | ((x,y),label) <- deps d] -- arcs and labels - ++ [Put (wpos rwld (root d) + 15,height) (ArrowDown (height-arcbase))] - ++ [Put (wpos rwld (root d) + 20,height - 10) (TinyText "ROOT")] - )] - where - wld i = wordLength d i -- >= 20.0 - rwld i = (wld i) / defaultWordLength -- >= 1.0 - aheight x y = depth (min x y) (max x y) + 1 ---- abs (x-y) - arcs = [(min u v, max u v) | ((u,v),_) <- deps d] - depth x y = case [(u,v) | (u,v) <- arcs, (x < u && v <= y) || (x == u && v < y)] of ---- only projective arcs counted - [] -> 0 - uvs -> 1 + maximum (0:[depth u v | (u,v) <- uvs]) - width = {-round-} (sum [wsize rwld w | (w,_) <- zip [0..] (tokens d)]) + {-round-} spaceLength * fromIntegral ((length (tokens d)) - 1) - height = 50 + 20 * {-round-} (maximum (0:[aheight x y | ((x,y),_) <- deps d])) - -type CoNLL = [[String]] -parseCoNLL :: String -> CoNLL -parseCoNLL = map words . lines - ---conll2dep :: String -> Dep ---conll2dep = conll2dep' . parseCoNLL - -conll2dep' :: CoNLL -> Dep -conll2dep' ls = Dep { - wordLength = wld - , tokens = toks - , deps = dps - , root = head $ [read x-1 | x:_:_:_:_:_:"0":_ <- ls] ++ [1] - } - where - wld i = maximum (0:[charWidth * fromIntegral (length w) | w <- let (tok,pos) = toks !! i in [tok,pos]]) - toks = [(w,c) | _:w:_:c:_ <- ls] - dps = [((read y-1, read x-1),lab) | x:_:_:_:_:_:y:lab:_ <- ls, y /="0"] - --maxdist = maximum [abs (x-y) | ((x,y),_) <- dps] - - --- * LaTeX Pictures (see https://en.wikibooks.org/wiki/LaTeX/Picture) - --- We render both LaTeX and SVG from this intermediate representation of --- LaTeX pictures. - -data LaTeX = Comment String | Picture UnitLengthMM Size [DrawingCommand] -data DrawingCommand = Put Position Object -data Object = Text String | TinyText String | OvalTop Size | ArrowDown Length - -type UnitLengthMM = Double -type Size = (Double,Double) -type Position = (Double,Double) -type Length = Double - - --- * latex formatting -ppLaTeX = vcat . map ppLaTeX1 - where - ppLaTeX1 el = - case el of - Comment s -> comment s - Picture unit size cmds -> - app "setlength{\\unitlength}" (text (show unit ++ "mm")) - $$ hang (app "begin" (text "picture")<>text (show size)) 2 - (vcat (map ppDrawingCommand cmds)) - $$ app "end" (text "picture") - $$ text "" - - ppDrawingCommand (Put pos obj) = put pos (ppObject obj) - - ppObject obj = - case obj of - Text s -> text s - TinyText s -> small (text s) - OvalTop size -> text "\\oval" <> text (show size) <> text "[t]" - ArrowDown len -> app "vector(0,-1)" (text (show len)) - - put p@(_,_) = app ("put" ++ show p) - small w = text "{\\tiny" <+> w <> text "}" - comment s = text "%%" <+> text s -- line break show follow - -app macro arg = text "\\" <> text macro <> text "{" <> arg <> text "}" - - -latexDoc :: Doc -> Doc -latexDoc body = - vcat [text "\\documentclass{article}", - text "\\usepackage[utf8]{inputenc}", - text "\\begin{document}", - body, - text "\\end{document}"] - - ----------------------------------- --- concrete syntax annotations (local) on top of conll --- examples of annotations: --- UseComp {"not"} PART neg head --- UseComp {*} AUX cop head - -type CncLabels = [(String, String -> Maybe (String -> String,String,String))] --- (fun, word -> (pos,label,target)) --- the pos can remain unchanged, as in the current notation in the article - -fixCoNLL :: CncLabels -> CoNLL -> CoNLL -fixCoNLL labels conll = map fixc conll where - fixc row = case row of - (i:word:fun:pos:cat:x_:"0":"dep":xs) -> (i:word:fun:pos:cat:x_:"0":"root":xs) --- change the root label from dep to root - (i:word:fun:pos:cat:x_:j:label:xs) -> case look (fun,word) of - Just (pos',label',"head") -> (i:word:fun:pos' pos:cat:x_:j :label':xs) - Just (pos',label',target) -> (i:word:fun:pos' pos:cat:x_: getDep j target:label':xs) - _ -> row - _ -> row - - look (fun,word) = case lookup fun labels of - Just relabel -> case relabel word of - Just row -> Just row - _ -> case lookup "*" labels of - Just starlabel -> starlabel word - _ -> Nothing - _ -> case lookup "*" labels of - Just starlabel -> starlabel word - _ -> Nothing - - getDep j label = maybe j id $ lookup (label,j) [((label,j),i) | i:word:fun:pos:cat:x_:j:label:xs <- conll] - -getCncDepLabels :: String -> CncLabels -getCncDepLabels = map merge . groupBy (\ (x,_) (a,_) -> x == a) . concatMap analyse . filter choose . lines where - --- choose is for compatibility with the general notation - choose line = notElem '(' line && elem '{' line --- ignoring non-local (with "(") and abstract (without "{") rules - - analyse line = case break (=='{') line of - (beg,_:ws) -> case break (=='}') ws of - (toks,_:target) -> case (words beg, words target) of - (fun:_,[ label,j]) -> [(fun, (tok, (id, label,j))) | tok <- getToks toks] - (fun:_,[pos,label,j]) -> [(fun, (tok, (const pos,label,j))) | tok <- getToks toks] - _ -> [] - _ -> [] - _ -> [] - merge rules@((fun,_):_) = (fun, \tok -> - case lookup tok (map snd rules) of - Just new -> return new - _ -> lookup "*" (map snd rules) - ) - getToks = words . map (\c -> if elem c "\"," then ' ' else c) - -printCoNLL :: CoNLL -> String -printCoNLL = unlines . map (concat . intersperse "\t") - ----------------------------------------------------------------------- -- Expressions & types @@ -1741,6 +1519,70 @@ readExpr str = freeStablePtr c_expr return (Just expr) +pExpr :: RP.ReadP Expr +pExpr = + RP.readS_to_P $ \str -> + unsafePerformIO $ + withText str $ \c_str -> + alloca $ \c_pos -> + mask_ $ do + c_expr <- pgf_read_expr_ex c_str c_pos unmarshaller + if c_expr == castPtrToStablePtr nullPtr + then return [] + else do expr <- deRefStablePtr c_expr + freeStablePtr c_expr + pos <- peek c_pos + size <- ((#peek PgfText, size) c_str) :: IO CSize + let c_text = castPtr c_str `plusPtr` (#offset PgfText, text) + s <- peekUtf8CString pos (c_text `plusPtr` fromIntegral size) + return [(expr,s)] + +pIdent :: RP.ReadP String +pIdent = + liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest) + `mplus` + do RP.char '\'' + cs <- RP.many1 insideChar + RP.char '\'' + return cs + +insideChar = RP.readS_to_P $ \s -> + case s of + [] -> [] + ('\\':'\\':cs) -> [('\\',cs)] + ('\\':'\'':cs) -> [('\'',cs)] + ('\\':cs) -> [] + ('\'':cs) -> [] + (c:cs) -> [(c,cs)] + +-- | Takes an identifier as a string and adds quotes if necessary +-- for escaping +showIdent :: String -> String +showIdent raw = + if isIdent raw + then raw + else "'" ++ concatMap escape raw ++ "'" + where + isIdent [] = False + isIdent (c:cs) = isIdentFirst c && all isIdentRest cs + + escape '\'' = "\\\'" + escape '\\' = "\\\\" + escape c = [c] + +isIdentFirst c = + (c == '_') || + (c >= 'a' && c <= 'z') || + (c >= 'A' && c <= 'Z') || + (c >= '\192' && c <= '\255' && c /= '\247' && c /= '\215') +isIdentRest c = + (c == '_') || + (c == '\'') || + (c >= '0' && c <= '9') || + (c >= 'a' && c <= 'z') || + (c >= 'A' && c <= 'Z') || + (c >= '\192' && c <= '\255' && c /= '\247' && c /= '\215') + -- | renders a type as a 'String'. The list -- of identifiers is the list of all free variables -- in the type in order reverse to the order