mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-09-19 08:46:02 -06:00
extend the backwards compatibility module PGF
This commit is contained in:
Krasimir Angelov
@@ -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]
|
||||
@@ -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)]
|
||||
+72
-230
@@ -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 <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 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
|
||||
|
||||
Reference in New Issue
Block a user