summaryrefslogtreecommitdiff
path: root/src/runtime/haskell
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime/haskell')
-rw-r--r--src/runtime/haskell/PGF/Binary.hs6
-rw-r--r--src/runtime/haskell/PGF/Data.hs9
-rw-r--r--src/runtime/haskell/PGF/Forest.hs2
-rw-r--r--src/runtime/haskell/PGF/Linearize.hs4
-rw-r--r--src/runtime/haskell/PGF/Macros.hs61
-rw-r--r--src/runtime/haskell/PGF/Morphology.hs4
-rw-r--r--src/runtime/haskell/PGF/Optimize.hs10
-rw-r--r--src/runtime/haskell/PGF/Parse.hs23
-rw-r--r--src/runtime/haskell/PGF/Printer.hs8
9 files changed, 73 insertions, 54 deletions
diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index 865f98417..3c9dcc265 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -76,10 +76,6 @@ instance Binary Concr where
, cnccats=cnccats, totalCats=totalCats
})
-instance Binary Alternative where
- put (Alt v x) = put (v,x)
- get = liftM2 Alt get get
-
instance Binary Expr where
put (EAbs b x exp) = putWord8 0 >> put (b,x,exp)
put (EApp e1 e2) = putWord8 1 >> put (e1,e2)
@@ -153,6 +149,7 @@ instance Binary Symbol where
put (SymKS ts) = putWord8 3 >> put ts
put (SymKP d vs) = putWord8 4 >> put (d,vs)
put SymNE = putWord8 5
+ put SymBIND = putWord8 6
get = do tag <- getWord8
case tag of
0 -> liftM2 SymCat get get
@@ -161,6 +158,7 @@ instance Binary Symbol where
3 -> liftM SymKS get
4 -> liftM2 (\d vs -> SymKP d vs) get get
5 -> return SymNE
+ 6 -> return SymBIND
_ -> decodingError
instance Binary PArg where
diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs
index 58ced6a1e..e86b02778 100644
--- a/src/runtime/haskell/PGF/Data.hs
+++ b/src/runtime/haskell/PGF/Data.hs
@@ -58,9 +58,10 @@ data Symbol
= SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
| SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
| SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int
- | SymKS [Token]
- | SymKP [Token] [Alternative]
+ | SymKS Token
| SymNE -- non exist
+ | SymBIND -- the special BIND token
+ | SymKP [Symbol] [([Symbol],[String])]
deriving (Eq,Ord,Show)
data Production
= PApply {-# UNPACK #-} !FunId [PArg]
@@ -75,10 +76,6 @@ type FunId = Int
type SeqId = Int
type BCAddr = Int
-data Alternative =
- Alt [Token] [String]
- deriving (Eq,Ord,Show)
-
-- merge two PGFs; fails is differens absnames; priority to second arg
diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs
index 9c47583ad..e6e3c1136 100644
--- a/src/runtime/haskell/PGF/Forest.hs
+++ b/src/runtime/haskell/PGF/Forest.hs
@@ -80,7 +80,7 @@ bracketedTokn dp f@(Forest abs cnc forest root) =
ltable = mkLinTable cnc isTrusted [] funid largs
in ((cat,fid),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) [[LeafKS ts]]))
+ descend forest (PConst cat e ts) = ((cat,fid),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 cf4c78193..7ff7d9c7a 100644
--- a/src/runtime/haskell/PGF/Linearize.hs
+++ b/src/runtime/haskell/PGF/Linearize.hs
@@ -82,7 +82,7 @@ linTree pgf lang e =
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))))
- ss s = listArray (0,0) [[LeafKS [s]]]
+ ss s = listArray (0,0) [[LeafKS s]]
apply :: Maybe CncType -> FId -> Expr -> [CId] -> [CId] -> CId -> [Expr] -> [(FId,(CncType, CId, [Expr], LinTable))]
apply mb_cty n_fid e0 ys xs f es =
@@ -115,7 +115,7 @@ linTree pgf lang e =
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))
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),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 2497d53ae..ffec9279f 100644
--- a/src/runtime/haskell/PGF/Macros.hs
+++ b/src/runtime/haskell/PGF/Macros.hs
@@ -156,9 +156,11 @@ data BracketedString
-- that represents the same constituent.
data BracketedTokn
- = LeafKS [Token]
- | LeafKP [Token] [Alternative]
- | Bracket_ CId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex CId [Expr] [BracketedTokn] -- Invariant: the list is not empty
+ = Bracket_ CId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex CId [Expr] [BracketedTokn] -- Invariant: the list is not empty
+ | LeafKS Token
+ | LeafNE
+ | LeafBIND
+ | LeafKP [BracketedTokn] [([BracketedTokn],[String])]
deriving Eq
type LinTable = ([CId],Array.Array LIndex [BracketedTokn])
@@ -178,21 +180,30 @@ lengthBracketedString (Leaf _) = 1
lengthBracketedString (Bracket _ _ _ _ _ bss) = sum (map lengthBracketedString bss)
untokn :: Maybe String -> BracketedTokn -> (Maybe String,[BracketedString])
-untokn nw (LeafKS ts) = (has_tok nw ts,map Leaf ts)
-untokn nw (LeafKP d vs) = let ts = filter (not . null) (sel d vs nw)
- in (has_tok nw ts,map Leaf ts)
- where
- sel d vs Nothing = d
- sel d vs (Just w) =
- case [v | Alt v cs <- vs, any (\c -> isPrefixOf c w) cs] of
- v:_ -> v
- _ -> d
-untokn nw (Bracket_ cat fid index fun es bss) =
- let (nw',bss') = mapAccumR untokn nw bss
- in (nw',[Bracket cat fid index fun es (concat bss')])
-
-has_tok nw [] = nw
-has_tok nw (t:ts) = Just t
+untokn nw bs =
+ case untokn nw bs of
+ (nw,Nothing ) -> (nw,[] )
+ (nw,Just bss) -> (nw,bss)
+ where
+ untokn nw (Bracket_ cat fid index fun es bss) =
+ let (nw',bss') = mapAccumR untokn nw bss
+ in case sequence bss' of
+ Just bss -> (nw',Just [Bracket cat fid index fun es (concat bss)])
+ Nothing -> (Nothing, Nothing)
+ untokn nw (LeafKS t)
+ | null t = (nw,Just [])
+ | otherwise = (Just t,Just [Leaf t])
+ untokn nw LeafNE = (Nothing, Nothing)
+ untokn nw (LeafKP d vs) = let (nw',bss') = mapAccumR untokn nw (sel d vs nw)
+ in case sequence bss' of
+ Just bss -> (nw',Just (concat bss))
+ Nothing -> (Nothing, Nothing)
+ where
+ sel d vs Nothing = d
+ sel d vs (Just w) =
+ case [v | (v,cs) <- vs, any (\c -> isPrefixOf c w) cs] of
+ v:_ -> v
+ _ -> d
type CncType = (CId, FId) -- concrete type is the abstract type (the category) + the forest id
@@ -204,11 +215,13 @@ mkLinTable cnc filter xs funid args = (xs,listArray (bounds lins) [computeSeq fi
computeSeq :: (CncType -> Bool) -> [Symbol] -> [(CncType,CId,[Expr],LinTable)] -> [BracketedTokn]
computeSeq filter seq args = concatMap compute seq
where
- compute (SymCat d r) = getArg d r
- compute (SymLit d r) = getArg d r
- compute (SymVar d r) = getVar d r
- compute (SymKS ts) = [LeafKS ts]
- compute (SymKP ts alts) = [LeafKP ts alts]
+ compute (SymCat d r) = getArg d r
+ compute (SymLit d r) = getArg d r
+ compute (SymVar d r) = getVar d r
+ compute (SymKS t) = [LeafKS t]
+ compute SymNE = [LeafNE]
+ compute SymBIND = [LeafKS "&+"]
+ compute (SymKP syms alts) = [LeafKP (concatMap compute syms) [(concatMap compute syms,cs) | (syms,cs) <- alts]]
getArg d r
| not (null arg_lin) &&
@@ -218,7 +231,7 @@ computeSeq filter seq args = concatMap compute seq
arg_lin = lin ! r
(ct@(cat,fid),fun,es,(xs,lin)) = args !! d
- getVar d r = [LeafKS [showCId (xs !! r)]]
+ getVar d r = [LeafKS (showCId (xs !! r))]
where
(ct,fun,es,(xs,lin)) = args !! d
diff --git a/src/runtime/haskell/PGF/Morphology.hs b/src/runtime/haskell/PGF/Morphology.hs
index 2f8fdecc2..894b64dfb 100644
--- a/src/runtime/haskell/PGF/Morphology.hs
+++ b/src/runtime/haskell/PGF/Morphology.hs
@@ -36,8 +36,8 @@ collectWords pinfo = Map.fromListWith (++)
, sym <- elems (sequences pinfo ! seqid)
, t <- sym2tokns sym]
where
- sym2tokns (SymKS ts) = ts
- sym2tokns (SymKP ts alts) = ts ++ [t | Alt ts ps <- alts, t <- ts]
+ sym2tokns (SymKS t) = [t]
+ sym2tokns (SymKP ts alts) = concat (map sym2tokns ts ++ [sym2tokns sym | (syms,ps) <- alts, sym <- syms])
sym2tokns _ = []
lookupMorpho :: Morpho -> String -> [(Lemma,Analysis)]
diff --git a/src/runtime/haskell/PGF/Optimize.hs b/src/runtime/haskell/PGF/Optimize.hs
index a339c9add..f04a8b04c 100644
--- a/src/runtime/haskell/PGF/Optimize.hs
+++ b/src/runtime/haskell/PGF/Optimize.hs
@@ -221,9 +221,13 @@ splitLexicalRules cnc p_prods =
wf ts = (ts,IntSet.singleton funid)
- seq2prefix [] = TrieMap.fromList [wf []]
- seq2prefix (SymKS ts :syms) = TrieMap.fromList [wf ts]
- seq2prefix (SymKP ts alts:syms) = TrieMap.fromList (wf ts : [wf ts | Alt ts ps <- alts])
+ seq2prefix [] = TrieMap.fromList [wf []]
+ seq2prefix (SymKS t :syms) = TrieMap.fromList [wf [t]]
+ seq2prefix (SymKP syms0 alts:syms) = TrieMap.unionsWith IntSet.union
+ (seq2prefix (syms0++syms) :
+ [seq2prefix (syms1 ++ syms) | (syms1,ps) <- alts])
+ seq2prefix (SymNE :syms) = TrieMap.empty
+ seq2prefix (SymBIND :syms) = TrieMap.fromList [wf ["&+"]]
updateConcrete abs cnc =
let p_prods0 = filterProductions IntMap.empty IntSet.empty (productions cnc)
diff --git a/src/runtime/haskell/PGF/Parse.hs b/src/runtime/haskell/PGF/Parse.hs
index 7057db3bc..e50f8436e 100644
--- a/src/runtime/haskell/PGF/Parse.hs
+++ b/src/runtime/haskell/PGF/Parse.hs
@@ -244,14 +244,12 @@ getParseOutput (PState abs cnc chart cnt) ty@(DTyp _ start _) dp =
flit _ = Nothing
ftok toks = TrieMap.unionWith Set.union (TrieMap.compose Nothing toks)
- cutAt ppos toks seqid =
+ cutAt ppos toks seqid =
let seq = unsafeAt (sequences cnc) seqid
init = take (ppos-1) (elems seq)
tail = case unsafeAt seq (ppos-1) of
- SymKS ts -> let ts' = reverse (drop (length toks) (reverse ts))
- in if null ts' then [] else [SymKS ts']
- SymKP ts _ -> let ts' = reverse (drop (length toks) (reverse ts))
- in if null ts' then [] else [SymKS ts']
+ SymKS t -> drop (length toks) [SymKS t]
+ SymKP ts _ -> reverse (drop (length toks) (reverse ts))
sym -> []
in init ++ tail
@@ -307,11 +305,18 @@ process flit ftok cnc (item@(Active j ppos funid seqid args key0):items) acc cha
Nothing -> process flit ftok cnc items4 acc' chart{active=insertAC key (Set.singleton item,new_sc) (active chart)}
Just (set,sc) | Set.member item set -> process flit ftok cnc items acc chart
| otherwise -> process flit ftok cnc items2 acc chart{active=insertAC key (Set.insert item set,IntMap.unionWith Set.union new_sc sc) (active chart)}
- SymKS toks -> let !acc' = ftok_ toks (Active j (ppos+1) funid seqid args key0) acc
+ SymKS tok -> let !acc' = ftok_ [tok] (Active j (ppos+1) funid seqid args key0) acc
in process flit ftok cnc items acc' chart
- SymKP strs vars
- -> let !acc' = foldl (\acc toks -> ftok_ toks (Active j (ppos+1) funid seqid args key0) acc) acc
- (strs:[strs' | Alt strs' _ <- vars])
+ SymNE -> process flit ftok cnc items acc chart
+ SymBIND -> let !acc' = ftok_ ["&+"] (Active j (ppos+1) funid seqid args key0) acc
+ in process flit ftok cnc items acc' chart
+ SymKP syms vars
+ -> let to_tok (SymKS t) = [t]
+ to_tok SymBIND = ["&+"]
+ to_tok _ = []
+
+ !acc' = foldl (\acc syms -> ftok_ (concatMap to_tok syms) (Active j (ppos+1) funid seqid args key0) acc) acc
+ (syms:[syms' | (syms',_) <- vars])
in process flit ftok cnc items acc' chart
SymLit d r -> let PArg hypos fid = args !! d
key = AK fid r
diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs
index c0529b116..9385e81c4 100644
--- a/src/runtime/haskell/PGF/Printer.hs
+++ b/src/runtime/haskell/PGF/Printer.hs
@@ -89,10 +89,12 @@ ppPrintName (id,name) =
ppSymbol (SymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
ppSymbol (SymLit d r) = char '{' <> int d <> comma <> int r <> char '}'
ppSymbol (SymVar d r) = char '<' <> int d <> comma <> char '$' <> int r <> char '>'
-ppSymbol (SymKS ts) = ppStrs ts
-ppSymbol (SymKP ts alts) = text "pre" <+> braces (hsep (punctuate semi (ppStrs ts : map ppAlt alts)))
+ppSymbol (SymKS t) = doubleQuotes (text t)
+ppSymbol SymNE = text "nonExist"
+ppSymbol SymBIND = text "BIND"
+ppSymbol (SymKP syms alts) = text "pre" <+> braces (hsep (punctuate semi (hsep (map ppSymbol syms) : map ppAlt alts)))
-ppAlt (Alt ts ps) = ppStrs ts <+> char '/' <+> hsep (map (doubleQuotes . text) ps)
+ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> char '/' <+> hsep (map (doubleQuotes . text) ps)
ppStrs ss = doubleQuotes (hsep (map text ss))
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:34:20 +0000