1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
-------------------------------------------------
-- |
-- Module : PGF
-- Maintainer : Krasimir Angelov
-- Stability : stable
-- Portability : portable
--
-- Forest is a compact representation of a set
-- of parse trees. This let us to efficiently
-- represent local ambiguities
--
-------------------------------------------------
module PGF.Forest( Forest(..)
, BracketedString, showBracketedString
, linearizeWithBrackets
) where
import PGF.CId
import PGF.Data
import PGF.Macros
import Data.List
import Data.Array.IArray
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntSet as IntSet
import qualified Data.IntMap as IntMap
import Control.Monad
data Forest
= Forest
{ abstr :: Abstr
, concr :: Concr
, forest :: IntMap.IntMap (Set.Set Production)
, root :: {-# UNPACK #-} !FId
, label :: {-# UNPACK #-} !LIndex
}
--------------------------------------------------------------------
-- Rendering of bracketed strings
--------------------------------------------------------------------
linearizeWithBrackets :: Forest -> BracketedString
linearizeWithBrackets = head . snd . untokn "" . bracketedTokn
---------------------------------------------------------------
-- Internally we have to do everything with Tokn first because
-- we must handle the pre {...} construction.
--
bracketedTokn :: Forest -> BracketedTokn
bracketedTokn (Forest abs cnc forest root label) =
let (fid,cat,lin) = render IntMap.empty root
in Bracket_ fid label cat (lin ! label)
where
trusted = trustedSpots IntSet.empty root
render parents fid =
case (IntMap.lookup fid parents) `mplus` (fmap Set.toList $ IntMap.lookup fid forest) of
Just (p:ps) -> descend (IntMap.insert fid ps parents) p
Nothing -> error ("wrong forest id " ++ show fid)
where
descend parents (PApply funid args) = let (CncFun fun lins) = cncfuns cnc ! funid
Just (DTyp _ cat _,_,_) = Map.lookup fun (funs abs)
largs = map (render parents) args
in (fid,cat,listArray (bounds lins) [computeSeq seqid largs | seqid <- elems lins])
descend parents (PCoerce fid) = render parents fid
descend parents (PConst cat _ ts) = (fid,cat,listArray (0,0) [[LeafKS ts]])
trustedSpots parents fid
| IntSet.member fid parents
= IntSet.empty
| otherwise = IntSet.insert fid $
case IntMap.lookup fid forest of
Just prods -> foldl1 IntSet.intersection [descend prod | prod <- Set.toList prods]
Nothing -> IntSet.empty
where
parents' = IntSet.insert fid parents
descend (PApply funid args) = IntSet.unions (map (trustedSpots parents') args)
descend (PCoerce fid) = trustedSpots parents' fid
descend (PConst c e _) = IntSet.empty
computeSeq :: SeqId -> [(FId,CId,LinTable)] -> [BracketedTokn]
computeSeq seqid args = concatMap compute (elems seq)
where
seq = sequences cnc ! seqid
compute (SymCat d r) = getArg d r
compute (SymLit d r) = getArg d r
compute (SymKS ts) = [LeafKS ts]
compute (SymKP ts alts) = [LeafKP ts alts]
getArg d r
| not (null arg_lin) &&
IntSet.member fid trusted
= [Bracket_ fid r cat arg_lin]
| otherwise = arg_lin
where
arg_lin = lin ! r
(fid,cat,lin) = args !! d
|
