GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-19 01:39:32 -06:00
Code Issues Packages Projects Releases Wiki Activity

a major refactoring in the C and the Haskell runtimes. Note incompatible change in the PGF format!!!

Browse Source 
The following are the outcomes:

   - Predef.nonExist is fully supported by both the Haskell and the C runtimes

   - Predef.BIND is now an internal compiler defined token. For now
     it behaves just as usual for the Haskell runtime, i.e. it generates &+.
     However, the special treatment will let us to handle it properly in 
     the C runtime.

   - This required a major change in the PGF format since both 
     nonExist and BIND may appear inside 'pre' and this was not supported
     before.
This commit is contained in:
kr.angelov
2013-09-27 15:09:48 +00:00
parent 3f65253f0e
commit efa4bc4d62
30 changed files with 332 additions and 372 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
src/runtime/haskell/PGF/Binary.hs
View File

@@ -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

9
src/runtime/haskell/PGF/Data.hs
View File

@@ -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

2
src/runtime/haskell/PGF/Forest.hs
View File

@@ -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

4
src/runtime/haskell/PGF/Linearize.hs
View File

@@ -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 = []

61
src/runtime/haskell/PGF/Macros.hs
View File

@@ -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

4
src/runtime/haskell/PGF/Morphology.hs
View File

@@ -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)]

10
src/runtime/haskell/PGF/Optimize.hs
View File

@@ -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)

23
src/runtime/haskell/PGF/Parse.hs
View File

@@ -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

8
src/runtime/haskell/PGF/Printer.hs
View File

@@ -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))