summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compiler/GF/Command/Commands.hs2
-rw-r--r--src/runtime/haskell/PGF/Forest.hs10
-rw-r--r--src/runtime/haskell/PGF/Linearize.hs45
-rw-r--r--src/runtime/haskell/PGF/Macros.hs21
-rw-r--r--src/runtime/haskell/PGF/VisualizeTree.hs18
-rw-r--r--src/server/PGFService.hs6
6 files changed, 54 insertions, 48 deletions
diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index 681b64f0d..8a19d2729 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -1166,7 +1166,7 @@ allCommands = Map.fromList [
map (map (unl . snd)) . tabularLinearizes pgf lang
_ | isOpt "table" opts -> unlines . concat . intersperse [[]] .
map (map (\(p,v) -> p+++":"+++unl v)) . tabularLinearizes pgf lang
- _ | isOpt "bracket" opts -> showBracketedString . bracketedLinearize pgf lang
+ _ | isOpt "bracket" opts -> unwords . map showBracketedString . bracketedLinearize pgf lang
_ -> unl . linearize pgf lang
-- replace each non-atomic constructor with mkC, where C is the val cat
diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs
index e6e3c1136..89ebfb299 100644
--- a/src/runtime/haskell/PGF/Forest.hs
+++ b/src/runtime/haskell/PGF/Forest.hs
@@ -47,7 +47,7 @@ data Forest
--------------------------------------------------------------------
linearizeWithBrackets :: Maybe Int -> Forest -> BracketedString
-linearizeWithBrackets dp = head . snd . untokn Nothing . bracketedTokn dp
+linearizeWithBrackets dp = head . snd . untokn Nothing . (:[]) .bracketedTokn dp
---------------------------------------------------------------
-- Internally we have to do everything with Tokn first because
@@ -67,8 +67,8 @@ bracketedTokn dp f@(Forest abs cnc forest root) =
render forest arg@(PArg hypos fid) =
case IntMap.lookup fid forest >>= Set.maxView of
- Just (p,set) -> let (ct,fun,es,(_,lin)) = descend (if Set.null set then forest else IntMap.insert fid set forest) p
- in (ct,fun,es,(map getVar hypos,lin))
+ Just (p,set) -> let (ct,fid',fun,es,(_,lin)) = descend (if Set.null set then forest else IntMap.insert fid set forest) p
+ in (ct,fid',fun,es,(map getVar hypos,lin))
Nothing -> error ("wrong forest id " ++ show fid)
where
descend forest (PApply funid args) = let (CncFun fun lins) = cncfuns cnc ! funid
@@ -78,9 +78,9 @@ bracketedTokn dp f@(Forest abs cnc forest root) =
Just (DTyp _ cat _,_,_,_,_) -> cat
largs = map (render forest) args
ltable = mkLinTable cnc isTrusted [] funid largs
- in ((cat,fid),wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable)
+ in ((cat,fid),0,wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable)
descend forest (PCoerce fid) = render forest (PArg [] fid)
- descend forest (PConst cat e ts) = ((cat,fid),wildCId,[e],([],listArray (0,0) [map LeafKS ts]))
+ descend forest (PConst cat e ts) = ((cat,fid),0,wildCId,[e],([],listArray (0,0) [map LeafKS ts]))
getVar (fid,_)
| fid == fidVar = wildCId
diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs
index 7ff7d9c7a..1e3aee02e 100644
--- a/src/runtime/haskell/PGF/Linearize.hs
+++ b/src/runtime/haskell/PGF/Linearize.hs
@@ -23,7 +23,9 @@ import qualified Data.Set as Set
-- | Linearizes given expression as string in the language
linearize :: PGF -> Language -> Tree -> String
-linearize pgf lang = concat . take 1 . map (unwords . concatMap flattenBracketedString . snd . untokn Nothing . firstLin) . linTree pgf lang
+linearize pgf lang = concat . take 1 . map (unwords . concatMap flattenBracketedString . snd . untokn Nothing . firstLin cnc) . linTree pgf cnc
+ where
+ cnc = lookMap (error "no lang") lang (concretes pgf)
-- | The same as 'linearizeAllLang' but does not return
-- the language.
@@ -36,24 +38,29 @@ linearizeAllLang :: PGF -> Tree -> [(Language,String)]
linearizeAllLang pgf t = [(lang,linearize pgf lang t) | lang <- Map.keys (concretes pgf)]
-- | Linearizes given expression as a bracketed string in the language
-bracketedLinearize :: PGF -> Language -> Tree -> BracketedString
-bracketedLinearize pgf lang = head . concat . map (snd . untokn Nothing . firstLin) . linTree pgf lang
+bracketedLinearize :: PGF -> Language -> Tree -> [BracketedString]
+bracketedLinearize pgf lang = concat . map (snd . untokn Nothing . firstLin cnc) . linTree pgf cnc
where
+ cnc = lookMap (error "no lang") lang (concretes pgf)
+
-- head [] = error "cannot linearize"
head [] = Leaf ""
-- so that linearize = flattenBracketedString . bracketedLinearize
head (bs:bss) = bs
-firstLin (_,arr)
- | inRange (bounds arr) 0 = arr ! 0
- | otherwise = LeafKS []
+firstLin cnc arg@(ct@(cat,n_fid),fid,fun,es,(xs,lin)) =
+ case IntMap.lookup fid (linrefs cnc) of
+ Just (funid:_) -> snd (mkLinTable cnc (const True) [] funid [arg]) ! 0
+ _ -> [LeafKS []]
-- | Creates a table from feature name to linearization.
-- The outher list encodes the variations
tabularLinearizes :: PGF -> Language -> Expr -> [[(String,String)]]
-tabularLinearizes pgf lang e = map cnv (linTree pgf lang e)
+tabularLinearizes pgf lang e = map cnv (linTree pgf cnc e)
where
- cnv ((cat,_),lin) = zip (lbls cat) $ map (unwords . concatMap flattenBracketedString . snd . untokn Nothing) (elems lin)
+ cnc = lookMap (error "no lang") lang (concretes pgf)
+
+ cnv (ct@(cat,_),_,_,_,(_,lin)) = zip (lbls cat) $ map (unwords . concatMap flattenBracketedString . snd . untokn Nothing) (elems lin)
lbls cat = case Map.lookup cat (cnccats (lookConcr pgf lang)) of
Just (CncCat _ _ lbls) -> elems lbls
@@ -63,11 +70,9 @@ tabularLinearizes pgf lang e = map cnv (linTree pgf lang e)
-- Implementation
--------------------------------------------------------------------
-linTree :: PGF -> Language -> Expr -> [(CncType, Array LIndex BracketedTokn)]
-linTree pgf lang e =
- nub [(ct,amapWithIndex (\label -> Bracket_ cat fid label fun es) lin) | (_,(ct@(cat,fid),fun,es,(xs,lin))) <- lin Nothing 0 e [] [] e []]
+linTree :: PGF -> Concr -> Expr -> [(CncType, FId, CId, [Expr], LinTable)]
+linTree pgf cnc e = nub (map snd (lin Nothing 0 e [] [] e []))
where
- cnc = lookMap (error "no lang") lang (concretes pgf)
lp = lproductions cnc
lin mb_cty n_fid e0 ys xs (EAbs _ x e) es = lin mb_cty n_fid e0 ys (x:xs) e es
@@ -78,18 +83,18 @@ linTree pgf lang e =
lin mb_cty n_fid e0 ys xs (EMeta i) es = def mb_cty n_fid e0 ys xs ('?':show i)
lin mb_cty n_fid e0 ys xs (EVar i) _ = def mb_cty n_fid e0 ys xs (showCId ((xs++ys) !! i))
lin mb_cty n_fid e0 ys xs (ELit l) [] = case l of
- LStr s -> return (n_fid+1,((cidString,n_fid),wildCId,[e0],([],ss s)))
- LInt n -> return (n_fid+1,((cidInt, n_fid),wildCId,[e0],([],ss (show n))))
- LFlt f -> return (n_fid+1,((cidFloat, n_fid),wildCId,[e0],([],ss (show f))))
+ LStr s -> return (n_fid+1,((cidString,n_fid),fidString,wildCId,[e0],([],ss s)))
+ LInt n -> return (n_fid+1,((cidInt, n_fid),fidInt, wildCId,[e0],([],ss (show n))))
+ LFlt f -> return (n_fid+1,((cidFloat, n_fid),fidFloat, wildCId,[e0],([],ss (show f))))
ss s = listArray (0,0) [[LeafKS s]]
- apply :: Maybe CncType -> FId -> Expr -> [CId] -> [CId] -> CId -> [Expr] -> [(FId,(CncType, CId, [Expr], LinTable))]
+ apply :: Maybe CncType -> FId -> Expr -> [CId] -> [CId] -> CId -> [Expr] -> [(FId,(CncType, FId, CId, [Expr], LinTable))]
apply mb_cty n_fid e0 ys xs f es =
case Map.lookup f lp of
Just prods -> do (funid,(cat,fid),ctys) <- getApps prods
(n_fid,args) <- descend n_fid (zip ctys es)
- return (n_fid+1,((cat,n_fid),f,[e0],mkLinTable cnc (const True) xs funid args))
+ return (n_fid+1,((cat,n_fid),fid,f,[e0],mkLinTable cnc (const True) xs funid args))
Nothing -> def mb_cty n_fid e0 ys xs ("[" ++ showCId f ++ "]") -- fun without lin
where
getApps prods =
@@ -112,10 +117,10 @@ linTree pgf lang e =
def (Just (cat,fid)) n_fid e0 ys xs s =
case IntMap.lookup fid (lindefs cnc) of
Just funs -> do funid <- funs
- let args = [((wildCId, n_fid),wildCId,[e0],([],ss s))]
- return (n_fid+2,((cat,n_fid+1),wildCId,[e0],mkLinTable cnc (const True) xs funid args))
+ let args = [((wildCId, n_fid),fidString,wildCId,[e0],([],ss s))]
+ return (n_fid+2,((cat,n_fid+1),fid,wildCId,[e0],mkLinTable cnc (const True) xs funid args))
Nothing
- | isPredefFId fid -> return (n_fid+2,((cat,n_fid+1),wildCId,[e0],(xs,listArray (0,0) [[LeafKS s]])))
+ | isPredefFId fid -> return (n_fid+2,((cat,n_fid+1),fid,wildCId,[e0],(xs,listArray (0,0) [[LeafKS s]])))
| otherwise -> do PCoerce fid <- maybe [] Set.toList (IntMap.lookup fid (pproductions cnc))
def (Just (cat,fid)) n_fid e0 ys xs s
def Nothing n_fid e0 ys xs s = []
diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs
index ffec9279f..ce0f8866e 100644
--- a/src/runtime/haskell/PGF/Macros.hs
+++ b/src/runtime/haskell/PGF/Macros.hs
@@ -179,11 +179,12 @@ lengthBracketedString :: BracketedString -> Int
lengthBracketedString (Leaf _) = 1
lengthBracketedString (Bracket _ _ _ _ _ bss) = sum (map lengthBracketedString bss)
-untokn :: Maybe String -> BracketedTokn -> (Maybe String,[BracketedString])
-untokn nw bs =
- case untokn nw bs of
- (nw,Nothing ) -> (nw,[] )
- (nw,Just bss) -> (nw,bss)
+untokn :: Maybe String -> [BracketedTokn] -> (Maybe String,[BracketedString])
+untokn nw bss =
+ let (nw',bss') = mapAccumR untokn nw bss
+ in case sequence bss' of
+ Just bss -> (nw,concat bss)
+ Nothing -> (nw,[])
where
untokn nw (Bracket_ cat fid index fun es bss) =
let (nw',bss') = mapAccumR untokn nw bss
@@ -207,12 +208,12 @@ untokn nw bs =
type CncType = (CId, FId) -- concrete type is the abstract type (the category) + the forest id
-mkLinTable :: Concr -> (CncType -> Bool) -> [CId] -> FunId -> [(CncType,CId,[Expr],LinTable)] -> LinTable
+mkLinTable :: Concr -> (CncType -> Bool) -> [CId] -> FunId -> [(CncType,FId,CId,[Expr],LinTable)] -> LinTable
mkLinTable cnc filter xs funid args = (xs,listArray (bounds lins) [computeSeq filter (elems (sequences cnc ! seqid)) args | seqid <- elems lins])
where
(CncFun _ lins) = cncfuns cnc ! funid
-computeSeq :: (CncType -> Bool) -> [Symbol] -> [(CncType,CId,[Expr],LinTable)] -> [BracketedTokn]
+computeSeq :: (CncType -> Bool) -> [Symbol] -> [(CncType,FId,CId,[Expr],LinTable)] -> [BracketedTokn]
computeSeq filter seq args = concatMap compute seq
where
compute (SymCat d r) = getArg d r
@@ -228,12 +229,12 @@ computeSeq filter seq args = concatMap compute seq
filter ct = [Bracket_ cat fid r fun es arg_lin]
| otherwise = arg_lin
where
- arg_lin = lin ! r
- (ct@(cat,fid),fun,es,(xs,lin)) = args !! d
+ arg_lin = lin ! r
+ (ct@(cat,fid),_,fun,es,(xs,lin)) = args !! d
getVar d r = [LeafKS (showCId (xs !! r))]
where
- (ct,fun,es,(xs,lin)) = args !! d
+ (ct,_,fun,es,(xs,lin)) = args !! d
flattenBracketedString :: BracketedString -> [String]
flattenBracketedString (Leaf w) = [w]
diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs
index 940d5950e..ed028feb8 100644
--- a/src/runtime/haskell/PGF/VisualizeTree.hs
+++ b/src/runtime/haskell/PGF/VisualizeTree.hs
@@ -137,11 +137,11 @@ graphvizDependencyTree format debug mlab ms pgf lang t = render $
nil = -1
- bs = bracketedLinearize pgf lang t
+ bss = bracketedLinearize pgf lang t
root = (wildCId,nil,wildCId)
- leaves = (root,0,root_lbl) : (groupAndIndexIt 1 . getLeaves root) bs
+ leaves = (root,0,root_lbl) : (groupAndIndexIt 1 . concatMap (getLeaves root)) bss
deps = let (_,(h,deps)) = getDeps 0 [] t []
in (h,(dep_lbl,nil)):deps
@@ -213,8 +213,8 @@ graphvizParseTree :: PGF -> Language -> GraphvizOptions -> Tree -> String
graphvizParseTree pgf lang opts = graphvizBracketedString opts . bracketedLinearize pgf lang
-graphvizBracketedString :: GraphvizOptions -> BracketedString -> String
-graphvizBracketedString opts bs = render graphviz_code
+graphvizBracketedString :: GraphvizOptions -> [BracketedString] -> String
+graphvizBracketedString opts bss = render graphviz_code
where
graphviz_code
= text "graph {" $$
@@ -250,10 +250,10 @@ graphvizBracketedString opts bs = render graphviz_code
nil = -1
internal_nodes = [mkLevel internals |
- internals <- getInternals [(nil, bs)],
+ internals <- getInternals (map ((,) nil) bss),
not (null internals)]
leaf_nodes = mkLevel [(parent, id, word) |
- (id, (parent, word)) <- zip [100000..] (getLeaves nil bs)]
+ (id, (parent, word)) <- zip [100000..] (concatMap (getLeaves nil) bss)]
getInternals [] = []
getInternals nodes
@@ -300,12 +300,12 @@ genPreAlignment pgf langs = lin2align . linsBracketed
where
linsBracketed t = [bracketedLinearize pgf lang t | lang <- langs]
- lin2align :: [BracketedString] -> PreAlign
- lin2align bss = PreAlign langSeqs langRels
+ lin2align :: [[BracketedString]] -> PreAlign
+ lin2align bsss = PreAlign langSeqs langRels
where
(langSeqs,langRels) = mkLayers leaves
nil = -1
- leaves = map (groupAndIndexIt 0 . getLeaves nil) bss
+ leaves = map (groupAndIndexIt 0 . concatMap (getLeaves nil)) bsss
groupAndIndexIt id [] = []
groupAndIndexIt id ((p,w):pws) = let (ws,pws1) = collect pws
diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs
index fcda86e7c..1f4e2bdce 100644
--- a/src/server/PGFService.hs
+++ b/src/server/PGFService.hs
@@ -601,9 +601,9 @@ linearizeTabular pgf tos tree =
vs = concat (PGF.tabularLinearizes pgf to t)
linearizeAndBind pgf mto tree =
- [(to,s,bs) | to<-langs,
- let bs = PGF.bracketedLinearize pgf to (transfer to tree)
- s = unwords . bind $ PGF.flattenBracketedString bs]
+ [(to,s,bss) | to<-langs,
+ let bss = PGF.bracketedLinearize pgf to (transfer to tree)
+ s = unwords . bind $ concatMap PGF.flattenBracketedString bss]
where
langs = if null mto then PGF.languages pgf else mto
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 15:22:44 +0000