summaryrefslogtreecommitdiff
path: root/src/runtime
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime')
-rw-r--r--src/runtime/haskell/PGF/Binary.hs19
-rw-r--r--src/runtime/haskell/PGF/Linearize.hs230
-rw-r--r--src/runtime/haskell/PGF/Macros.hs72
-rw-r--r--src/runtime/haskell/PGF/Morphology.hs24
-rw-r--r--src/runtime/haskell/PGF/PMCFG.hs32
-rw-r--r--src/runtime/haskell/PGF/Parse.hs4
-rw-r--r--src/runtime/haskell/PGF/ShowLinearize.hs114
-rw-r--r--src/runtime/haskell/PGF/VisualizeTree.hs10
8 files changed, 200 insertions, 305 deletions
diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index 7d5db73af..a9a6a78dc 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -2,6 +2,7 @@ module PGF.Binary where
import PGF.CId
import PGF.Data
+import PGF.Macros
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
@@ -28,10 +29,11 @@ instance Binary PGF where
gflags <- get
abstract <- get
concretes <- get
- return (PGF{ absname=absname, cncnames=cncnames
- , gflags=gflags
- , abstract=abstract, concretes=concretes
- })
+ return $ updateProductionIndices $
+ (PGF{ absname=absname, cncnames=cncnames
+ , gflags=gflags
+ , abstract=abstract, concretes=concretes
+ })
instance Binary CId where
put (CId bs) = put bs
@@ -185,15 +187,16 @@ instance Binary Production where
_ -> decodingError
instance Binary ParserInfo where
- put p = put (functions p, sequences p, productions0 p, totalCats p, startCats p)
+ put p = put (functions p, sequences p, productions p, totalCats p, startCats p)
get = do functions <- get
sequences <- get
- productions0<- get
+ productions <- get
totalCats <- get
startCats <- get
return (ParserInfo{functions=functions,sequences=sequences
- ,productions0=productions0
- ,productions =filterProductions productions0
+ ,productions = productions
+ ,pproductions = IntMap.empty
+ ,lproductions = Map.empty
,totalCats=totalCats,startCats=startCats})
decodingError = fail "This PGF file was compiled with different version of GF"
diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs
index de3daf11d..9058cba61 100644
--- a/src/runtime/haskell/PGF/Linearize.hs
+++ b/src/runtime/haskell/PGF/Linearize.hs
@@ -1,38 +1,81 @@
-{-# LANGUAGE ParallelListComp #-}
-module PGF.Linearize
- (linearizes,showPrintName,realize,realizes,linTree, linTreeMark,linearizesMark) where
+module PGF.Linearize(linearizes,markLinearizes,tabularLinearizes) where
import PGF.CId
import PGF.Data
import PGF.Macros
-import PGF.Tree
-
+import Data.Maybe (fromJust)
+import Data.Array.IArray
+import Data.List
import Control.Monad
import qualified Data.Map as Map
-import Data.List
-
-import Debug.Trace
+import qualified Data.IntMap as IntMap
+import qualified Data.Set as Set
-- linearization and computation of concrete PGF Terms
-linearizes :: PGF -> CId -> Expr -> [String]
-linearizes pgf lang = realizes . linTree pgf lang
-
-realize :: Term -> String
-realize = concat . take 1 . realizes
+type LinTable = Array FIndex [Tokn]
-realizes :: Term -> [String]
-realizes = map (unwords . untokn) . realizest
+linearizes :: PGF -> CId -> Expr -> [String]
+linearizes pgf lang = map (unwords . untokn . (! 0)) . linTree pgf lang (\_ _ lint -> lint)
-realizest :: Term -> [[Tokn]]
-realizest trm = case trm of
- R ts -> realizest (ts !! 0)
- S ss -> map concat $ combinations $ map realizest ss
- K t -> [[t]]
- W s t -> [[KS (s ++ r)] | [KS r] <- realizest t]
- FV ts -> concatMap realizest ts
- TM s -> [[KS s]]
- _ -> [[KS $ "REALIZE_ERROR " ++ show trm]] ---- debug
+linTree :: PGF -> Language -> (Maybe CId -> [Int] -> LinTable -> LinTable) -> Expr -> [LinTable]
+linTree pgf lang mark e = lin0 [] [] [] Nothing e
+ where
+ cnc = lookMap (error "no lang") lang (concretes pgf)
+ pinfo = fromJust (parser cnc)
+ lp = lproductions pinfo
+
+ lin0 path xs ys mb_fid (EAbs _ x e) = lin0 path (showCId x:xs) ys mb_fid e
+ lin0 path xs ys mb_fid (ETyped e _) = lin0 path xs ys mb_fid e
+ lin0 path xs ys mb_fid e | null xs = lin path ys mb_fid e []
+ | otherwise = apply path (xs ++ ys) mb_fid _B (e:[ELit (LStr x) | x <- xs])
+
+ lin path xs mb_fid (EApp e1 e2) es = lin path xs mb_fid e1 (e2:es)
+ lin path xs mb_fid (ELit l) [] = case l of
+ LStr s -> return (mark Nothing path (ss s))
+ LInt n -> return (mark Nothing path (ss (show n)))
+ LFlt f -> return (mark Nothing path (ss (show f)))
+ lin path xs mb_fid (EMeta i) es = apply path xs mb_fid _V (ELit (LStr ('?':show i)):es)
+ lin path xs mb_fid (EFun f) es = map (mark (Just f) path) (apply path xs mb_fid f es)
+ lin path xs mb_fid (EVar i) es = apply path xs mb_fid _V (ELit (LStr (xs !! i)) :es)
+ lin path xs mb_fid (ETyped e _) es = lin path xs mb_fid e es
+ lin path xs mb_fid (EImplArg e) es = lin path xs mb_fid e es
+
+ ss s = listArray (0,0) [[KS s]]
+
+ apply path xs mb_fid f es =
+ case Map.lookup f lp of
+ Just prods -> case lookupProds mb_fid prods of
+ Just set -> do prod <- Set.toList set
+ case prod of
+ FApply funid fids -> do guard (length fids == length es)
+ args <- sequence (zipWith3 (\i fid e -> lin0 (sub i path) [] xs (Just fid) e) [0..] fids es)
+ let (FFun _ lins) = functions pinfo ! funid
+ return (listArray (bounds lins) [computeSeq seqid args | seqid <- elems lins])
+ FCoerce fid -> apply path xs (Just fid) f es
+ Nothing -> mzero
+ Nothing -> apply path xs mb_fid _V [ELit (LStr "?")] -- function without linearization
+ where
+ lookupProds (Just fid) prods = IntMap.lookup fid prods
+ lookupProds Nothing prods
+ | f == _B || f == _V = Nothing
+ | otherwise = Just (Set.filter isApp (Set.unions (IntMap.elems prods)))
+
+ sub i path
+ | f == _B || f == _V = path
+ | otherwise = i:path
+
+ isApp (FApply _ _) = True
+ isApp _ = False
+
+ computeSeq seqid args = concatMap compute (elems seq)
+ where
+ seq = sequences pinfo ! seqid
+
+ compute (FSymCat d r) = (args !! d) ! r
+ compute (FSymLit d r) = (args !! d) ! r
+ compute (FSymKS ts) = map KS ts
+ compute (FSymKP ts alts) = [KP ts alts]
untokn :: [Tokn] -> [String]
untokn ts = case ts of
@@ -45,126 +88,23 @@ untokn ts = case ts of
v:_ -> v
_ -> d
--- Lifts all variants to the top level (except those in macros).
-liftVariants :: Term -> [Term]
-liftVariants = f
- where
- f (R ts) = liftM R $ mapM f ts
- f (P t1 t2) = liftM2 P (f t1) (f t2)
- f (S ts) = liftM S $ mapM f ts
- f (FV ts) = ts >>= f
- f (W s t) = liftM (W s) $ f t
- f t = return t
-
-linTree :: PGF -> CId -> Expr -> Term
-linTree pgf lang e = lin (expr2tree e) Nothing
+-- create a table from labels+params to variants
+tabularLinearizes :: PGF -> CId -> Expr -> [[(String,String)]]
+tabularLinearizes pgf lang e = map (zip lbls . map (unwords . untokn) . elems) (linTree pgf lang (\_ _ lint -> lint) e)
where
- cnc = lookMap (error "no lang") lang (concretes pgf)
-
- lin (Abs xs e ) mty = case lin e Nothing of
- R ts -> R $ ts ++ (Data.List.map (kks . showCId . snd) xs)
- TM s -> R $ (TM s) : (Data.List.map (kks . showCId . snd) xs)
- lin (Fun fun es) mty = case Map.lookup fun (funs (abstract pgf)) of
- Just (DTyp hyps _ _,_,_) -> let argVariants = sequence [liftVariants (lin e (Just ty)) | e <- es | (_,_,ty) <- hyps]
- in variants [compute pgf lang args $ lookMap tm0 fun (lins cnc) | args <- argVariants]
- Nothing -> tm0
- lin (Lit (LStr s)) mty = R [kks (show s)] -- quoted
- lin (Lit (LInt i)) mty = R [kks (show i)]
- lin (Lit (LFlt d)) mty = R [kks (show d)]
- lin (Var x) mty = case mty of
- Just (DTyp _ cat _) -> compute pgf lang [K (KS (showCId x))] (lookMap tm0 cat (lindefs cnc))
- Nothing -> TM (showCId x)
- lin (Meta i) mty = case mty of
- Just (DTyp _ cat _) -> compute pgf lang [K (KS ("?" ++ show i))] (lookMap tm0 cat (lindefs cnc))
- Nothing -> TM (show i)
-
-variants :: [Term] -> Term
-variants ts = case ts of
- [t] -> t
- _ -> FV ts
-
-unvariants :: Term -> [Term]
-unvariants t = case t of
- FV ts -> ts
- _ -> [t]
-
-compute :: PGF -> CId -> [Term] -> Term -> Term
-compute pgf lang args = comp where
- comp trm = case trm of
- P r p -> proj (comp r) (comp p)
- W s t -> W s (comp t)
- R ts -> R $ map comp ts
- V i -> idx args i -- already computed
- F c -> comp $ look c -- not computed (if contains argvar)
- FV ts -> FV $ map comp ts
- S ts -> S $ filter (/= S []) $ map comp ts
- _ -> trm
-
- look = lookOper pgf lang
-
- idx xs i = if i > length xs - 1
- then trace
- ("too large " ++ show i ++ " for\n" ++ unlines (map show xs) ++ "\n") tm0
- else xs !! i
-
- proj r p = case (r,p) of
- (_, FV ts) -> FV $ map (proj r) ts
- (FV ts, _ ) -> FV $ map (\t -> proj t p) ts
- (W s t, _) -> kks (s ++ getString (proj t p))
- _ -> comp $ getField r (getIndex p)
-
- getString t = case t of
- K (KS s) -> s
- _ -> error ("ERROR in grammar compiler: string from "++ show t) "ERR"
-
- getIndex t = case t of
- C i -> i
- TM _ -> 0 -- default value for parameter
- _ -> trace ("ERROR in grammar compiler: index from " ++ show t) 666
-
- getField t i = case t of
- R rs -> idx rs i
- TM s -> TM s
- _ -> error ("ERROR in grammar compiler: field from " ++ show t) t
-
----------
--- markup with tree positions
-
-linearizesMark :: PGF -> CId -> Expr -> [String]
-linearizesMark pgf lang = realizes . linTreeMark pgf lang
-
-linTreeMark :: PGF -> CId -> Expr -> Term
-linTreeMark pgf lang = lin [] . expr2tree
+ lbls = case unApp e of
+ Just (f,_) -> let cat = valCat (lookType pgf f)
+ in case parser (lookConcr pgf lang) >>= Map.lookup cat . startCats of
+ Just (_,_,lbls) -> elems lbls
+ Nothing -> error "No labels"
+ Nothing -> error "Not function application"
+
+
+-- show bracketed markup with references to tree structure
+markLinearizes :: PGF -> CId -> Expr -> [String]
+markLinearizes pgf lang = map (unwords . untokn . (! 0)) . linTree pgf lang mark
where
- lin p (Abs xs e ) = case lin p e of
- R ts -> R $ ts ++ (Data.List.map (kks . showCId . snd) xs)
- TM s -> R $ (TM s) : (Data.List.map (kks . showCId . snd) xs)
- lin p (Fun fun es) =
- let argVariants =
- mapM (\ (i,e) -> liftVariants $ lin (sub p i) e) (zip [0..] es)
- in variants [mark (fun,p) $ compute pgf lang args $ look fun |
- args <- argVariants]
- lin p (Lit (LStr s)) = mark p $ R [kks (show s)] -- quoted
- lin p (Lit (LInt i)) = mark p $ R [kks (show i)]
- lin p (Lit (LFlt d)) = mark p $ R [kks (show d)]
- lin p (Var x) = mark p $ TM (showCId x)
- lin p (Meta i) = mark p $ TM (show i)
-
- look = lookLin pgf lang
-
- mark :: Show a => a -> Term -> Term
- mark p t = case t of
- R ts -> R $ map (mark p) ts
- FV ts -> R $ map (mark p) ts
- S ts -> S $ bracket p ts
- K s -> S $ bracket p [t]
- W s (R ts) -> R [mark p $ kks (s ++ u) | K (KS u) <- ts]
- _ -> t
- -- otherwise in normal form
-
- bracket p ts = [kks ("("++show p)] ++ ts ++ [kks ")"]
- sub p i = p ++ [i]
-
--- | Show the printname of function or category
-showPrintName :: PGF -> Language -> CId -> String
-showPrintName pgf lang id = lookMap "?" id $ printnames $ lookMap (error "no lang") lang $ concretes pgf
+ mark mb_f path lint = amap (bracket mb_f path) lint
+
+ bracket Nothing path ts = [KS ("("++show (reverse path))] ++ ts ++ [KS ")"]
+ bracket (Just f) path ts = [KS ("(("++showCId f++","++show (reverse path)++")")] ++ ts ++ [KS ")"]
diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs
index 81f946211..bf6252f2a 100644
--- a/src/runtime/haskell/PGF/Macros.hs
+++ b/src/runtime/haskell/PGF/Macros.hs
@@ -3,10 +3,14 @@ module PGF.Macros where
import PGF.CId
import PGF.Data
import Control.Monad
-import qualified Data.Map as Map
-import qualified Data.Array as Array
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.IntMap as IntMap
+import qualified Data.IntSet as IntSet
+import qualified Data.Array as Array
import Data.Maybe
import Data.List
+import GF.Data.Utilities(sortNub)
-- operations for manipulating PGF grammars and objects
@@ -122,6 +126,10 @@ contextLength :: Type -> Int
contextLength ty = case ty of
DTyp hyps _ _ -> length hyps
+-- | Show the printname of function or category
+showPrintName :: PGF -> Language -> CId -> String
+showPrintName pgf lang id = lookMap "?" id $ printnames $ lookMap (error "no lang") lang $ concretes pgf
+
term0 :: CId -> Term
term0 = TM . showCId
@@ -151,3 +159,63 @@ cidVar = mkCId "__gfVar"
_B = mkCId "__gfB"
_V = mkCId "__gfV"
+
+updateProductionIndices :: PGF -> PGF
+updateProductionIndices pgf = pgf{concretes = fmap updateConcrete (concretes pgf)}
+ where
+ updateConcrete cnc =
+ case parser cnc of
+ Nothing -> cnc
+ Just pinfo -> let prods0 = filterProductions (productions pinfo)
+ p_prods = parseIndex pinfo prods0
+ l_prods = linIndex pinfo prods0
+ in cnc{parser = Just pinfo{pproductions = p_prods, lproductions = l_prods}}
+
+ filterProductions prods0
+ | IntMap.size prods == IntMap.size prods0 = prods
+ | otherwise = filterProductions prods
+ where
+ prods = IntMap.mapMaybe (filterProdSet prods0) prods0
+
+ filterProdSet prods set0
+ | Set.null set = Nothing
+ | otherwise = Just set
+ where
+ set = Set.filter (filterRule prods) set0
+
+ filterRule prods (FApply funid args) = all (\fcat -> isLiteralFCat fcat || IntMap.member fcat prods) args
+ filterRule prods (FCoerce fcat) = isLiteralFCat fcat || IntMap.member fcat prods
+ filterRule prods _ = True
+
+ parseIndex pinfo = IntMap.mapMaybeWithKey filterProdSet
+ where
+ filterProdSet fid prods
+ | fid `IntSet.member` ho_fids = Just prods
+ | otherwise = let prods' = Set.filter (not . is_ho_prod) prods
+ in if Set.null prods'
+ then Nothing
+ else Just prods'
+
+ is_ho_prod (FApply _ [fid]) | fid == fcatVar = True
+ is_ho_prod _ = False
+
+ ho_fids :: IntSet.IntSet
+ ho_fids = IntSet.fromList [fid | cat <- ho_cats
+ , fid <- maybe [] (\(s,e,_) -> [s..e]) (Map.lookup cat (startCats pinfo))]
+
+ ho_cats :: [CId]
+ ho_cats = sortNub [c | (ty,_,_) <- Map.elems (funs (abstract pgf))
+ , h <- case ty of {DTyp hyps val _ -> hyps}
+ , let ty = typeOfHypo h
+ , c <- fst (catSkeleton ty)]
+
+ linIndex pinfo productions =
+ Map.fromListWith (IntMap.unionWith Set.union)
+ [(fun,IntMap.singleton res (Set.singleton prod)) | (res,prods) <- IntMap.toList productions
+ , prod <- Set.toList prods
+ , fun <- getFunctions prod]
+ where
+ getFunctions (FApply funid args) = let FFun fun _ = functions pinfo Array.! funid in [fun]
+ getFunctions (FCoerce fid) = case IntMap.lookup fid productions of
+ Nothing -> []
+ Just prods -> [fun | prod <- Set.toList prods, fun <- getFunctions prod] \ No newline at end of file
diff --git a/src/runtime/haskell/PGF/Morphology.hs b/src/runtime/haskell/PGF/Morphology.hs
index 9eee71a97..be786ebbb 100644
--- a/src/runtime/haskell/PGF/Morphology.hs
+++ b/src/runtime/haskell/PGF/Morphology.hs
@@ -2,11 +2,13 @@ module PGF.Morphology(Lemma,Analysis,Morpho,
buildMorpho,
lookupMorpho,fullFormLexicon) where
-import PGF.ShowLinearize (collectWords)
-import PGF.Data
import PGF.CId
+import PGF.Data
import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.IntMap as IntMap
+import Data.Array.IArray
import Data.List (intersperse)
-- these 4 definitions depend on the datastructure used
@@ -17,7 +19,23 @@ type Analysis = String
newtype Morpho = Morpho (Map.Map String [(Lemma,Analysis)])
buildMorpho :: PGF -> Language -> Morpho
-buildMorpho pgf lang = Morpho (Map.fromListWith (++) (collectWords pgf lang))
+buildMorpho pgf lang = Morpho $
+ case Map.lookup lang (concretes pgf) >>= parser of
+ Just pinfo -> collectWords pinfo
+ Nothing -> Map.empty
+
+collectWords pinfo = Map.fromListWith (++)
+ [(t, [(fun,lbls ! l)]) | (s,e,lbls) <- Map.elems (startCats pinfo)
+ , fid <- [s..e]
+ , FApply funid _ <- maybe [] Set.toList (IntMap.lookup fid (pproductions pinfo))
+ , let FFun fun lins = functions pinfo ! funid
+ , (l,seqid) <- assocs lins
+ , sym <- elems (sequences pinfo ! seqid)
+ , t <- sym2tokns sym]
+ where
+ sym2tokns (FSymKS ts) = ts
+ sym2tokns (FSymKP ts alts) = ts ++ [t | Alt ts ps <- alts, t <- ts]
+ sym2tokns _ = []
lookupMorpho :: Morpho -> String -> [(Lemma,Analysis)]
lookupMorpho (Morpho mo) s = maybe [] id $ Map.lookup s mo
diff --git a/src/runtime/haskell/PGF/PMCFG.hs b/src/runtime/haskell/PGF/PMCFG.hs
index abf7e4380..0ef0e3295 100644
--- a/src/runtime/haskell/PGF/PMCFG.hs
+++ b/src/runtime/haskell/PGF/PMCFG.hs
@@ -34,12 +34,13 @@ data Alternative =
deriving (Eq,Ord,Show)
data ParserInfo
- = ParserInfo { functions :: Array FunId FFun
- , sequences :: Array SeqId FSeq
- , productions0:: IntMap.IntMap (Set.Set Production) -- this are the original productions as they are loaded from the PGF file
- , productions :: IntMap.IntMap (Set.Set Production) -- this are the productions after the filtering for useless productions
- , startCats :: Map.Map CId (FCat,FCat,Array FIndex String) -- for every category - start/end FCat and a list of label names
- , totalCats :: {-# UNPACK #-} !FCat
+ = ParserInfo { functions :: Array FunId FFun
+ , sequences :: Array SeqId FSeq
+ , productions :: IntMap.IntMap (Set.Set Production) -- the original productions loaded from the PGF file
+ , pproductions :: IntMap.IntMap (Set.Set Production) -- productions needed for parsing
+ , lproductions :: Map.Map CId (IntMap.IntMap (Set.Set Production)) -- productions needed for linearization
+ , startCats :: Map.Map CId (FCat,FCat,Array FIndex String) -- for every category - start/end FCat and a list of label names
+ , totalCats :: {-# UNPACK #-} !FCat
}
@@ -98,22 +99,3 @@ ppFCat fcat
ppFunId funid = char 'F' <> int funid
ppSeqId seqid = char 'S' <> int seqid
-
-
-filterProductions = closure
- where
- closure prods0
- | IntMap.size prods == IntMap.size prods0 = prods
- | otherwise = closure prods
- where
- prods = IntMap.mapMaybe (filterProdSet prods0) prods0
-
- filterProdSet prods set0
- | Set.null set = Nothing
- | otherwise = Just set
- where
- set = Set.filter (filterRule prods) set0
-
- filterRule prods (FApply funid args) = all (\fcat -> isLiteralFCat fcat || IntMap.member fcat prods) args
- filterRule prods (FCoerce fcat) = isLiteralFCat fcat || IntMap.member fcat prods
- filterRule prods _ = True
diff --git a/src/runtime/haskell/PGF/Parse.hs b/src/runtime/haskell/PGF/Parse.hs
index e9936233c..5a4ccc719 100644
--- a/src/runtime/haskell/PGF/Parse.hs
+++ b/src/runtime/haskell/PGF/Parse.hs
@@ -59,7 +59,7 @@ initState pgf lang (DTyp _ start _) =
let items = case Map.lookup start (startCats pinfo) of
Just (s,e,labels) -> do cat <- range (s,e)
(funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args)
- [] cat (productions pinfo)
+ [] cat (pproductions pinfo)
let FFun fn lins = functions pinfo ! funid
(lbl,seqid) <- assocs lins
return (Active 0 0 funid seqid args (AK cat lbl))
@@ -72,7 +72,7 @@ initState pgf lang (DTyp _ start _) =
in PState pgf
pinfo
- (Chart emptyAC [] emptyPC (productions pinfo) (totalCats pinfo) 0)
+ (Chart emptyAC [] emptyPC (pproductions pinfo) (totalCats pinfo) 0)
(TMap.singleton [] (Set.fromList items))
-- | From the current state and the next token
diff --git a/src/runtime/haskell/PGF/ShowLinearize.hs b/src/runtime/haskell/PGF/ShowLinearize.hs
deleted file mode 100644
index fa4de86c8..000000000
--- a/src/runtime/haskell/PGF/ShowLinearize.hs
+++ /dev/null
@@ -1,114 +0,0 @@
-module PGF.ShowLinearize (
- collectWords,
- tableLinearize,
- recordLinearize,
- termLinearize,
- tabularLinearize,
- allLinearize,
- markLinearize
- ) where
-
-import PGF.CId
-import PGF.Data
-import PGF.Tree
-import PGF.Macros
-import PGF.Linearize
-
-import GF.Data.Operations
-import Data.List
-import qualified Data.Map as Map
-
--- printing linearizations in different ways with source parameters
-
--- internal representation, only used internally in this module
-data Record =
- RR [(String,Record)]
- | RT [(String,Record)]
- | RFV [Record]
- | RS String
- | RCon String
-
-prRecord :: Record -> String
-prRecord = prr where
- prr t = case t of
- RR fs -> concat $
- "{" :
- (intersperse ";" (map (\ (l,v) -> unwords [l,"=", prr v]) fs)) ++ ["}"]
- RT fs -> concat $
- "table {" :
- (intersperse ";" (map (\ (l,v) -> unwords [l,"=>",prr v]) fs)) ++ ["}"]
- RFV ts -> concat $
- "variants {" : (intersperse ";" (map prr ts)) ++ ["}"]
- RS s -> prQuotedString s
- RCon s -> s
-
--- uses the encoding of record types in PGF.paramlincat
-mkRecord :: Term -> Term -> Record
-mkRecord typ trm = case (typ,trm) of
- (_, FV ts) -> RFV $ map (mkRecord typ) ts
- (R rs, R ts) -> RR [(str lab, mkRecord ty t) | (P lab ty, t) <- zip rs ts]
- (S [FV ps,ty],R ts) -> RT [(str par, mkRecord ty t) | (par, t) <- zip ps ts]
- (_,W s (R ts)) -> mkRecord typ (R [K (KS (s ++ u)) | K (KS u) <- ts])
- (FV ps, C i) -> RCon $ str $ ps !! i
- (S [], _) -> case realizes trm of
- [s] -> RS s
- ss -> RFV $ map RS ss
- _ -> RS $ show trm ---- printTree trm
- where
- str = realize
-
--- show all branches, without labels and params
-allLinearize :: (String -> String) -> PGF -> CId -> Expr -> String
-allLinearize unlex pgf lang = concat . map (unlex . pr) . tabularLinearize pgf lang where
- pr (p,vs) = unlines vs
-
--- show all branches, with labels and params
-tableLinearize :: (String -> String) -> PGF -> CId -> Expr -> String
-tableLinearize unlex pgf lang = unlines . map pr . tabularLinearize pgf lang where
- pr (p,vs) = p +++ ":" +++ unwords (intersperse "|" (map unlex vs))
-
--- create a table from labels+params to variants
-tabularLinearize :: PGF -> CId -> Expr -> [(String,[String])]
-tabularLinearize pgf lang = branches . recLinearize pgf lang where
- branches r = case r of
- RR fs -> [(lab +++ b,s) | (lab,t) <- fs, (b,s) <- branches t]
- RT fs -> [(lab +++ b,s) | (lab,t) <- fs, (b,s) <- branches t]
- RFV rs -> concatMap branches rs
- RS s -> [([], [s])]
- RCon _ -> []
-
--- show record in GF-source-like syntax
-recordLinearize :: PGF -> CId -> Expr -> String
-recordLinearize pgf lang = prRecord . recLinearize pgf lang
-
--- create a GF-like record, forming the basis of all functions above
-recLinearize :: PGF -> CId -> Expr -> Record
-recLinearize pgf lang tree = mkRecord typ $ linTree pgf lang tree where
- typ = case expr2tree tree of
- Fun f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f
-
--- show PGF term
-termLinearize :: PGF -> CId -> Expr -> String
-termLinearize pgf lang = show . linTree pgf lang
-
--- show bracketed markup with references to tree structure
-markLinearize :: PGF -> CId -> Expr -> String
-markLinearize pgf lang = concat . take 1 . linearizesMark pgf lang
-
-
--- for Morphology: word, lemma, tags
-collectWords :: PGF -> Language -> [(String, [(CId,String)])]
-collectWords pgf lang =
- concatMap collOne
- [(f,c,length xs) | (f,(DTyp xs c _,_,_)) <- Map.toList $ funs $ abstract pgf]
- where
- collOne (f,c,i) =
- fromRec f [showCId c] (recLinearize pgf lang (foldl EApp (EFun f) (replicate i (EMeta 888))))
- fromRec f v r = case r of
- RR rs -> concat [fromRec f v t | (_,t) <- rs]
- RT rs -> concat [fromRec f (p:v) t | (p,t) <- rs]
- RFV rs -> concatMap (fromRec f v) rs
- RS s -> [(w,[(f,unwords (reverse v))]) | w <- words s, w /= "?888"] ---
--- RS s -> [(s,[(f,unwords (reverse v))])]
- RCon c -> [] ---- inherent
-
diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs
index 429551f54..8e9b28740 100644
--- a/src/runtime/haskell/PGF/VisualizeTree.hs
+++ b/src/runtime/haskell/PGF/VisualizeTree.hs
@@ -102,7 +102,7 @@ graphvizDependencyTree format debug mlab ms pgf lang exp = case format of
ifd s = if debug then s else []
- pot = readPosText $ head $ linearizesMark pgf lang exp
+ pot = readPosText $ concat $ take 1 $ markLinearizes pgf lang exp
---- use Just str if you have str to match against
prelude = ["rankdir=LR ;", "node [shape = plaintext] ;"]
@@ -188,9 +188,7 @@ getDepLabels ss = Map.fromList [(mkCId f,ls) | f:ls <- map words ss]
---- nubrec and domins are quadratic, but could be (n log n)
graphvizParseTree :: PGF -> CId -> Expr -> String
-graphvizParseTree pgf lang = prGraph False . lin2tree pgf . linMark where
- linMark = head . linearizesMark pgf lang
- ---- use Just str if you have str to match against
+graphvizParseTree pgf lang = prGraph False . lin2tree pgf . concat . take 1 . markLinearizes pgf lang where
lin2tree pgf s = trace s $ prelude ++ nodes ++ links where
@@ -235,12 +233,12 @@ tag s = "<" ++ s ++ ">"
showp = init . tail . show
mtag = tag . ('n':) . uncommas
--- word alignments from Linearize.linearizesMark
+-- word alignments from Linearize.markLinearize
-- words are chunks like {[0,1,1,0] old}
graphvizAlignment :: PGF -> Expr -> String
graphvizAlignment pgf = prGraph True . lin2graph . linsMark where
- linsMark t = [s | la <- cncnames pgf, s <- take 1 (linearizesMark pgf la t)]
+ linsMark t = [concat (take 1 (markLinearizes pgf la t)) | la <- cncnames pgf]
lin2graph :: [String] -> [String]
lin2graph ss = trace (show ss) $ prelude ++ nodes ++ links
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:25:03 +0000