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

extend the backwards compatibility module PGF

Browse Source
This commit is contained in:
Krasimir Angelov
2026-09-15 08:48:55 +02:00
parent dc512e0ec4
commit 4e80f9eceb
3 changed files with 709 additions and 346 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/runtime/haskell/PGF.hs
+637
View File
@@ -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 <grammar file name>
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]
src/runtime/haskell/PGF.hsc
-116
View File
@@ -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 <pgf/pgf.h>
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)]
src/runtime/haskell/PGF2.hsc
+72 -230
View File
@@ -32,7 +32,7 @@ module PGF2 (-- * PGF
functionType, functionIsConstructor, functionProbability, functionType, functionIsConstructor, functionProbability,
-- ** Expressions -- ** Expressions
Expr(..), Literal(..), showExpr, readExpr, Expr(..), Literal(..), showExpr, showIdent, readExpr, pExpr, pIdent,
mkAbs, unAbs, Var, mkAbs, unAbs, Var,
mkApp, unApp, unapply, mkApp, unApp, unapply,
mkVar, unVar, mkVar, unVar,
@@ -71,8 +71,6 @@ module PGF2 (-- * PGF
-- ** Visualizations -- ** Visualizations
GraphvizOptions(..), graphvizDefaults, GraphvizOptions(..), graphvizDefaults,
graphvizAbstractTree, graphvizParseTree, graphvizAbstractTree, graphvizParseTree,
Labels, getDepLabels,
graphvizDependencyTree, conlls2latexDoc, getCncDepLabels,
graphvizWordAlignment, graphvizWordAlignment,
-- * Concrete syntax -- * Concrete syntax
@@ -83,7 +81,7 @@ module PGF2 (-- * PGF
FId, BracketedString(..), showBracketedString, flattenBracketedString, FId, BracketedString(..), showBracketedString, flattenBracketedString,
bracketedLinearize, bracketedLinearizeAll, bracketedLinearize, bracketedLinearizeAll,
hasLinearization, categoryFields, hasLinearization, categoryFields,
printName, alignWords, gizaAlignment, printName, alignWords,
-- ** Parsing -- ** Parsing
ParseOutput(..), parse, robustParse, parseWithHeuristics, complete, ParseOutput(..), parse, robustParse, parseWithHeuristics, complete,
@@ -102,7 +100,7 @@ import PGF2.FFI
import Foreign import Foreign
import Foreign.C import Foreign.C
import Control.Monad(forM,forM_) import Control.Monad(forM,forM_,liftM2,mplus)
import Control.Exception(bracket,mask_,throwIO) import Control.Exception(bracket,mask_,throwIO)
import System.IO.Unsafe(unsafePerformIO, unsafeInterleaveIO) import System.IO.Unsafe(unsafePerformIO, unsafeInterleaveIO)
import System.Random import System.Random
@@ -112,6 +110,7 @@ import Data.List(intersperse,groupBy)
import Data.Char(isUpper,isSpace,isPunctuation) import Data.Char(isUpper,isSpace,isPunctuation)
import Data.Maybe(maybe) import Data.Maybe(maybe)
import Text.PrettyPrint import Text.PrettyPrint
import qualified Text.ParserCombinators.ReadP as RP
#ifdef __linux__ #ifdef __linux__
#define _GNU_SOURCE #define _GNU_SOURCE
@@ -119,7 +118,10 @@ import Text.PrettyPrint
#endif #endif
#include <pgf/pgf.h> #include <pgf/pgf.h>
-- | 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 <grammar file name>
readPGF :: FilePath -> IO PGF readPGF :: FilePath -> IO PGF
readPGF fpath = readPGFWithProbs fpath Nothing readPGF fpath = readPGFWithProbs fpath Nothing
@@ -661,8 +663,6 @@ alignWords c e = unsafePerformIO $
free ptr free ptr
return (phrase, map fromIntegral fids) return (phrase, map fromIntegral fids)
gizaAlignment = error "TODO: gizaAlignment"
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Functions using Concr -- Functions using Concr
-- Morpho analyses, parsing & linearization -- Morpho analyses, parsing & linearization
@@ -1477,228 +1477,6 @@ graphvizWordAlignment cs opts e =
then return "" then return ""
else peekText c_text 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 -- Expressions & types
@@ -1741,6 +1519,70 @@ readExpr str =
freeStablePtr c_expr freeStablePtr c_expr
return (Just 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 -- | renders a type as a 'String'. The list
-- of identifiers is the list of all free variables -- of identifiers is the list of all free variables
-- in the type in order reverse to the order -- in the type in order reverse to the order