summaryrefslogtreecommitdiff
path: root/src/runtime/haskell/PGF
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime/haskell/PGF')
-rw-r--r--src/runtime/haskell/PGF/Binary.hs47
-rw-r--r--src/runtime/haskell/PGF/Check.hs24
-rw-r--r--src/runtime/haskell/PGF/Data.hs57
-rw-r--r--src/runtime/haskell/PGF/Linearize.hs10
-rw-r--r--src/runtime/haskell/PGF/Macros.hs33
-rw-r--r--src/runtime/haskell/PGF/Morphology.hs2
-rw-r--r--src/runtime/haskell/PGF/PMCFG.hs101
-rw-r--r--src/runtime/haskell/PGF/Parse.hs51
-rw-r--r--src/runtime/haskell/PGF/Printer.hs89
9 files changed, 203 insertions, 211 deletions
diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index a9a6a78dc..66caef1da 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -51,24 +51,24 @@ instance Binary Abstr where
})
instance Binary Concr where
- put cnc = put ( cflags cnc, lins cnc, opers cnc
- , lincats cnc, lindefs cnc
- , printnames cnc, paramlincats cnc
- , parser cnc
+ put cnc = put ( cflags cnc, printnames cnc
+ , functions cnc, sequences cnc
+ , productions cnc
+ , totalCats cnc, startCats cnc
)
- get = do cflags <- get
- lins <- get
- opers <- get
- lincats <- get
- lindefs <- get
- printnames <- get
- paramlincats <- get
- parser <- get
- return (Concr{ cflags=cflags, lins=lins, opers=opers
- , lincats=lincats, lindefs=lindefs
- , printnames=printnames
- , paramlincats=paramlincats
- , parser=parser
+ get = do cflags <- get
+ printnames <- get
+ functions <- get
+ sequences <- get
+ productions <- get
+ totalCats <- get
+ startCats <- get
+ return (Concr{ cflags=cflags, printnames=printnames
+ , functions=functions,sequences=sequences
+ , productions = productions
+ , pproductions = IntMap.empty
+ , lproductions = Map.empty
+ , totalCats=totalCats,startCats=startCats
})
instance Binary Alternative where
@@ -186,17 +186,4 @@ instance Binary Production where
1 -> liftM FCoerce get
_ -> decodingError
-instance Binary ParserInfo where
- put p = put (functions p, sequences p, productions p, totalCats p, startCats p)
- get = do functions <- get
- sequences <- get
- productions <- get
- totalCats <- get
- startCats <- get
- return (ParserInfo{functions=functions,sequences=sequences
- ,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/Check.hs b/src/runtime/haskell/PGF/Check.hs
index 58b66cfe4..6ac8c9b20 100644
--- a/src/runtime/haskell/PGF/Check.hs
+++ b/src/runtime/haskell/PGF/Check.hs
@@ -1,4 +1,4 @@
-module PGF.Check (checkPGF) where
+module PGF.Check (checkPGF,checkLin) where
import PGF.CId
import PGF.Data
@@ -7,14 +7,15 @@ import GF.Data.ErrM
import qualified Data.Map as Map
import Control.Monad
+import Data.Maybe(fromMaybe)
import Debug.Trace
checkPGF :: PGF -> Err (PGF,Bool)
-checkPGF pgf = do
+checkPGF pgf = return (pgf,True) {- do
(cs,bs) <- mapM (checkConcrete pgf)
(Map.assocs (concretes pgf)) >>= return . unzip
return (pgf {concretes = Map.fromAscList cs}, and bs)
-
+-}
-- errors are non-fatal; replace with 'fail' to change this
msg s = trace s (return ())
@@ -27,7 +28,7 @@ labelBoolErr ms iob = do
(x,b) <- iob
if b then return (x,b) else (msg ms >> return (x,b))
-
+{-
checkConcrete :: PGF -> (CId,Concr) -> Err ((CId,Concr),Bool)
checkConcrete pgf (lang,cnc) =
labelBoolErr ("happened in language " ++ showCId lang) $ do
@@ -35,8 +36,11 @@ checkConcrete pgf (lang,cnc) =
return ((lang,cnc{lins = Map.fromAscList rs}),and bs)
where
checkl = checkLin pgf lang
+-}
-checkLin :: PGF -> CId -> (CId,Term) -> Err ((CId,Term),Bool)
+type PGFSig = (Map.Map CId (Type,Int,[Equation]),Map.Map CId Term,Map.Map CId Term)
+
+checkLin :: PGFSig -> CId -> (CId,Term) -> Err ((CId,Term),Bool)
checkLin pgf lang (f,t) =
labelBoolErr ("happened in function " ++ showCId f) $ do
(t',b) <- checkTerm (lintype pgf lang f) t --- $ inline pgf lang t
@@ -124,8 +128,8 @@ ints = C
str :: CType
str = S []
-lintype :: PGF -> CId -> CId -> LinType
-lintype pgf lang fun = case typeSkeleton (lookType pgf fun) of
+lintype :: PGFSig -> CId -> CId -> LinType
+lintype pgf lang fun = case typeSkeleton (lookFun pgf fun) of
(cs,c) -> (map vlinc cs, linc c) ---- HOAS
where
linc = lookLincat pgf lang
@@ -133,7 +137,7 @@ lintype pgf lang fun = case typeSkeleton (lookType pgf fun) of
vlinc (i,c) = case linc c of
R ts -> R (ts ++ replicate i str)
-inline :: PGF -> CId -> Term -> Term
+inline :: PGFSig -> CId -> Term -> Term
inline pgf lang t = case t of
F c -> inl $ look c
_ -> composSafeOp inl t
@@ -171,3 +175,7 @@ err :: (String -> b) -> (a -> b) -> Err a -> b
err d f e = case e of
Ok a -> f a
Bad s -> d s
+
+lookFun (abs,lin,lincats) f = (\(a,b,c) -> a) $ fromMaybe (error "No abs") (Map.lookup f abs)
+lookLincat (abs,lin,lincats) _ c = fromMaybe (error "No lincat") (Map.lookup c lincats)
+lookLin (abs,lin,lincats) _ f = fromMaybe (error "No lin") (Map.lookup f lin)
diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs
index dcdf38dcb..7b3f3435f 100644
--- a/src/runtime/haskell/PGF/Data.hs
+++ b/src/runtime/haskell/PGF/Data.hs
@@ -1,15 +1,17 @@
-module PGF.Data (module PGF.Data, module PGF.Expr, module PGF.Type, module PGF.PMCFG) where
+module PGF.Data (module PGF.Data, module PGF.Expr, module PGF.Type) where
import PGF.CId
import PGF.Expr hiding (Value, Env, Tree)
import PGF.Type
-import PGF.PMCFG
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.IntMap as IntMap
+import Data.Array.IArray
+import Data.Array.Unboxed
import Data.List
+
-- internal datatypes for PGF
-- | An abstract data type representing multilingual grammar
@@ -30,16 +32,40 @@ data Abstr = Abstr {
}
data Concr = Concr {
- cflags :: Map.Map CId String, -- value of a flag
- lins :: Map.Map CId Term, -- lin of a fun
- opers :: Map.Map CId Term, -- oper generated by subex elim
- lincats :: Map.Map CId Term, -- lin type of a cat
- lindefs :: Map.Map CId Term, -- lin default of a cat
- printnames :: Map.Map CId String, -- printname of a cat or a fun
- paramlincats :: Map.Map CId Term, -- lin type of cat, with printable param names
- parser :: Maybe ParserInfo -- parser
+ cflags :: Map.Map CId String, -- value of a flag
+ printnames :: Map.Map CId String, -- printname of a cat or a fun
+ 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
}
+type FCat = Int
+type FIndex = Int
+type FPointPos = Int
+data FSymbol
+ = FSymCat {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex
+ | FSymLit {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex
+ | FSymKS [String]
+ | FSymKP [String] [Alternative]
+ deriving (Eq,Ord,Show)
+data Production
+ = FApply {-# UNPACK #-} !FunId [FCat]
+ | FCoerce {-# UNPACK #-} !FCat
+ | FConst Expr [String]
+ deriving (Eq,Ord,Show)
+data FFun = FFun CId {-# UNPACK #-} !(UArray FIndex SeqId) deriving (Eq,Ord,Show)
+type FSeq = Array FPointPos FSymbol
+type FunId = Int
+type SeqId = Int
+
+data Alternative =
+ Alt [String] [String]
+ deriving (Eq,Ord,Show)
+
data Term =
R [Term]
| P Term Term
@@ -59,7 +85,7 @@ data Tokn =
deriving (Eq,Ord,Show)
--- merge two GFCCs; fails is differens absnames; priority to second arg
+-- merge two PGFs; fails is differens absnames; priority to second arg
unionPGF :: PGF -> PGF -> PGF
unionPGF one two = case absname one of
@@ -93,3 +119,12 @@ readLanguage = readCId
showLanguage :: Language -> String
showLanguage = showCId
+
+fcatString, fcatInt, fcatFloat, fcatVar :: Int
+fcatString = (-1)
+fcatInt = (-2)
+fcatFloat = (-3)
+fcatVar = (-4)
+
+isLiteralFCat :: FCat -> Bool
+isLiteralFCat = (`elem` [fcatString, fcatInt, fcatFloat, fcatVar])
diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs
index 9058cba61..3d6624e28 100644
--- a/src/runtime/haskell/PGF/Linearize.hs
+++ b/src/runtime/haskell/PGF/Linearize.hs
@@ -3,7 +3,6 @@ module PGF.Linearize(linearizes,markLinearizes,tabularLinearizes) where
import PGF.CId
import PGF.Data
import PGF.Macros
-import Data.Maybe (fromJust)
import Data.Array.IArray
import Data.List
import Control.Monad
@@ -22,8 +21,7 @@ linTree :: PGF -> Language -> (Maybe CId -> [Int] -> LinTable -> LinTable) -> Ex
linTree pgf lang mark e = lin0 [] [] [] Nothing e
where
cnc = lookMap (error "no lang") lang (concretes pgf)
- pinfo = fromJust (parser cnc)
- lp = lproductions pinfo
+ lp = lproductions cnc
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
@@ -50,7 +48,7 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e
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
+ let (FFun _ lins) = functions cnc ! funid
return (listArray (bounds lins) [computeSeq seqid args | seqid <- elems lins])
FCoerce fid -> apply path xs (Just fid) f es
Nothing -> mzero
@@ -70,7 +68,7 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e
computeSeq seqid args = concatMap compute (elems seq)
where
- seq = sequences pinfo ! seqid
+ seq = sequences cnc ! seqid
compute (FSymCat d r) = (args !! d) ! r
compute (FSymLit d r) = (args !! d) ! r
@@ -94,7 +92,7 @@ tabularLinearizes pgf lang e = map (zip lbls . map (unwords . untokn) . elems) (
where
lbls = case unApp e of
Just (f,_) -> let cat = valCat (lookType pgf f)
- in case parser (lookConcr pgf lang) >>= Map.lookup cat . startCats of
+ in case Map.lookup cat (startCats (lookConcr pgf lang)) of
Just (_,_,lbls) -> elems lbls
Nothing -> error "No labels"
Nothing -> error "Not function application"
diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs
index bf6252f2a..de6436425 100644
--- a/src/runtime/haskell/PGF/Macros.hs
+++ b/src/runtime/haskell/PGF/Macros.hs
@@ -17,22 +17,6 @@ import GF.Data.Utilities(sortNub)
mapConcretes :: (Concr -> Concr) -> PGF -> PGF
mapConcretes f pgf = pgf { concretes = Map.map f (concretes pgf) }
-lookLin :: PGF -> CId -> CId -> Term
-lookLin pgf lang fun =
- lookMap tm0 fun $ lins $ lookMap (error "no lang") lang $ concretes pgf
-
-lookOper :: PGF -> CId -> CId -> Term
-lookOper pgf lang fun =
- lookMap tm0 fun $ opers $ lookMap (error "no lang") lang $ concretes pgf
-
-lookLincat :: PGF -> CId -> CId -> Term
-lookLincat pgf lang fun =
- lookMap tm0 fun $ lincats $ lookMap (error "no lang") lang $ concretes pgf
-
-lookParamLincat :: PGF -> CId -> CId -> Term
-lookParamLincat pgf lang fun =
- lookMap tm0 fun $ paramlincats $ lookMap (error "no lang") lang $ concretes pgf
-
lookType :: PGF -> CId -> Type
lookType pgf f =
case lookMap (error $ "lookType " ++ show f) f (funs (abstract pgf)) of
@@ -52,9 +36,6 @@ isData pgf f =
lookValCat :: PGF -> CId -> CId
lookValCat pgf = valCat . lookType pgf
-lookParser :: PGF -> CId -> Maybe ParserInfo
-lookParser pgf lang = Map.lookup lang (concretes pgf) >>= parser
-
lookStartCat :: PGF -> CId
lookStartCat pgf = mkCId $ fromMaybe "S" $ msum $ Data.List.map (Map.lookup (mkCId "startcat"))
[gflags pgf, aflags (abstract pgf)]
@@ -86,7 +67,7 @@ missingLins pgf lang = [c | c <- fs, not (hasl c)] where
hasl = hasLin pgf lang
hasLin :: PGF -> CId -> CId -> Bool
-hasLin pgf lang f = Map.member f $ lins $ lookConcr pgf lang
+hasLin pgf lang f = Map.member f $ lproductions $ lookConcr pgf lang
restrictPGF :: (CId -> Bool) -> PGF -> PGF
restrictPGF cond pgf = pgf {
@@ -164,13 +145,11 @@ 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}}
-
+ let prods0 = filterProductions (productions cnc)
+ p_prods = parseIndex cnc prods0
+ l_prods = linIndex cnc prods0
+ in cnc{pproductions = p_prods, lproductions = l_prods}
+
filterProductions prods0
| IntMap.size prods == IntMap.size prods0 = prods
| otherwise = filterProductions prods
diff --git a/src/runtime/haskell/PGF/Morphology.hs b/src/runtime/haskell/PGF/Morphology.hs
index be786ebbb..c77aa1735 100644
--- a/src/runtime/haskell/PGF/Morphology.hs
+++ b/src/runtime/haskell/PGF/Morphology.hs
@@ -20,7 +20,7 @@ newtype Morpho = Morpho (Map.Map String [(Lemma,Analysis)])
buildMorpho :: PGF -> Language -> Morpho
buildMorpho pgf lang = Morpho $
- case Map.lookup lang (concretes pgf) >>= parser of
+ case Map.lookup lang (concretes pgf) of
Just pinfo -> collectWords pinfo
Nothing -> Map.empty
diff --git a/src/runtime/haskell/PGF/PMCFG.hs b/src/runtime/haskell/PGF/PMCFG.hs
deleted file mode 100644
index 0ef0e3295..000000000
--- a/src/runtime/haskell/PGF/PMCFG.hs
+++ /dev/null
@@ -1,101 +0,0 @@
-module PGF.PMCFG where
-
-import PGF.CId
-import PGF.Expr
-
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Data.IntMap as IntMap
-import Data.Array.IArray
-import Data.Array.Unboxed
-import Text.PrettyPrint
-
-type FCat = Int
-type FIndex = Int
-type FPointPos = Int
-data FSymbol
- = FSymCat {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex
- | FSymLit {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex
- | FSymKS [String]
- | FSymKP [String] [Alternative]
- deriving (Eq,Ord,Show)
-data Production
- = FApply {-# UNPACK #-} !FunId [FCat]
- | FCoerce {-# UNPACK #-} !FCat
- | FConst Expr [String]
- deriving (Eq,Ord,Show)
-data FFun = FFun CId {-# UNPACK #-} !(UArray FIndex SeqId) deriving (Eq,Ord,Show)
-type FSeq = Array FPointPos FSymbol
-type FunId = Int
-type SeqId = Int
-
-data Alternative =
- Alt [String] [String]
- deriving (Eq,Ord,Show)
-
-data ParserInfo
- = 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
- }
-
-
-fcatString, fcatInt, fcatFloat, fcatVar :: Int
-fcatString = (-1)
-fcatInt = (-2)
-fcatFloat = (-3)
-fcatVar = (-4)
-
-isLiteralFCat :: FCat -> Bool
-isLiteralFCat = (`elem` [fcatString, fcatInt, fcatFloat, fcatVar])
-
-ppPMCFG :: ParserInfo -> Doc
-ppPMCFG pinfo =
- text "productions" $$
- nest 2 (vcat [ppProduction (fcat,prod) | (fcat,set) <- IntMap.toList (productions pinfo), prod <- Set.toList set]) $$
- text "functions" $$
- nest 2 (vcat (map ppFun (assocs (functions pinfo)))) $$
- text "sequences" $$
- nest 2 (vcat (map ppSeq (assocs (sequences pinfo)))) $$
- text "startcats" $$
- nest 2 (vcat (map ppStartCat (Map.toList (startCats pinfo))))
-
-ppProduction (fcat,FApply funid args) =
- ppFCat fcat <+> text "->" <+> ppFunId funid <> brackets (hcat (punctuate comma (map ppFCat args)))
-ppProduction (fcat,FCoerce arg) =
- ppFCat fcat <+> text "->" <+> char '_' <> brackets (ppFCat arg)
-ppProduction (fcat,FConst _ ss) =
- ppFCat fcat <+> text "->" <+> ppStrs ss
-
-ppFun (funid,FFun fun arr) =
- ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun)
-
-ppSeq (seqid,seq) =
- ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol (elems seq))
-
-ppStartCat (id,(start,end,labels)) =
- ppCId id <+> text ":=" <+> (text "range " <+> brackets (ppFCat start <+> text ".." <+> ppFCat end) $$
- text "labels" <+> brackets (vcat (map (text . show) (elems labels))))
-
-ppSymbol (FSymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
-ppSymbol (FSymLit d r) = char '<' <> int d <> comma <> int r <> char '>'
-ppSymbol (FSymKS ts) = ppStrs ts
-ppSymbol (FSymKP ts alts) = text "pre" <+> braces (hsep (punctuate semi (ppStrs ts : map ppAlt alts)))
-
-ppAlt (Alt ts ps) = ppStrs ts <+> char '/' <+> hsep (map (doubleQuotes . text) ps)
-
-ppStrs ss = doubleQuotes (hsep (map text ss))
-
-ppFCat fcat
- | fcat == fcatString = text "CString"
- | fcat == fcatInt = text "CInt"
- | fcat == fcatFloat = text "CFloat"
- | fcat == fcatVar = text "CVar"
- | otherwise = char 'C' <> int fcat
-
-ppFunId funid = char 'F' <> int funid
-ppSeqId seqid = char 'S' <> int seqid
diff --git a/src/runtime/haskell/PGF/Parse.hs b/src/runtime/haskell/PGF/Parse.hs
index 5a4ccc719..e02ccd9ca 100644
--- a/src/runtime/haskell/PGF/Parse.hs
+++ b/src/runtime/haskell/PGF/Parse.hs
@@ -56,23 +56,20 @@ parseWithRecovery pgf lang typ open_typs toks = accept (initState pgf lang typ)
-- startup category.
initState :: PGF -> Language -> Type -> ParseState
initState pgf lang (DTyp _ start _) =
- let items = case Map.lookup start (startCats pinfo) of
+ let items = case Map.lookup start (startCats cnc) of
Just (s,e,labels) -> do cat <- range (s,e)
(funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args)
- [] cat (pproductions pinfo)
- let FFun fn lins = functions pinfo ! funid
+ [] cat (pproductions cnc)
+ let FFun fn lins = functions cnc ! funid
(lbl,seqid) <- assocs lins
return (Active 0 0 funid seqid args (AK cat lbl))
Nothing -> mzero
- pinfo =
- case lookParser pgf lang of
- Just pinfo -> pinfo
- _ -> error ("Unknown language: " ++ showCId lang)
+ cnc = lookConcr pgf lang
in PState pgf
- pinfo
- (Chart emptyAC [] emptyPC (pproductions pinfo) (totalCats pinfo) 0)
+ cnc
+ (Chart emptyAC [] emptyPC (pproductions cnc) (totalCats cnc) 0)
(TMap.singleton [] (Set.fromList items))
-- | From the current state and the next token
@@ -81,19 +78,19 @@ initState pgf lang (DTyp _ start _) =
-- If the new token cannot be accepted then an error state
-- is returned.
nextState :: ParseState -> String -> Either ErrorState ParseState
-nextState (PState pgf pinfo chart items) t =
+nextState (PState pgf cnc chart items) t =
let (mb_agenda,map_items) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda
acc = fromMaybe TMap.empty (Map.lookup t map_items)
- (acc1,chart1) = process (Just t) add (sequences pinfo) (functions pinfo) agenda acc chart
+ (acc1,chart1) = process (Just t) add (sequences cnc) (functions cnc) agenda acc chart
chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1
, passive=emptyPC
, offset =offset chart1+1
}
in if TMap.null acc1
- then Left (EState pgf pinfo chart2)
- else Right (PState pgf pinfo chart2 acc1)
+ then Left (EState pgf cnc chart2)
+ else Right (PState pgf cnc chart2 acc1)
where
add (tok:toks) item acc
| tok == t = TMap.insertWith Set.union toks (Set.singleton item) acc
@@ -104,35 +101,35 @@ nextState (PState pgf pinfo chart items) t =
-- next words and the consequent states. This is used for word completions in
-- the GF interpreter.
getCompletions :: ParseState -> String -> Map.Map String ParseState
-getCompletions (PState pgf pinfo chart items) w =
+getCompletions (PState pgf cnc chart items) w =
let (mb_agenda,map_items) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda
acc = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items
- (acc',chart1) = process Nothing add (sequences pinfo) (functions pinfo) agenda acc chart
+ (acc',chart1) = process Nothing add (sequences cnc) (functions cnc) agenda acc chart
chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1
, passive=emptyPC
, offset =offset chart1+1
}
- in fmap (PState pgf pinfo chart2) acc'
+ in fmap (PState pgf cnc chart2) acc'
where
add (tok:toks) item acc
| isPrefixOf w tok = Map.insertWith (TMap.unionWith Set.union) tok (TMap.singleton toks (Set.singleton item)) acc
add _ item acc = acc
recoveryStates :: [Type] -> ErrorState -> (ParseState, Map.Map String ParseState)
-recoveryStates open_types (EState pgf pinfo chart) =
+recoveryStates open_types (EState pgf cnc chart) =
let open_fcats = concatMap type2fcats open_types
agenda = foldl (complete open_fcats) [] (actives chart)
- (acc,chart1) = process Nothing add (sequences pinfo) (functions pinfo) agenda Map.empty chart
+ (acc,chart1) = process Nothing add (sequences cnc) (functions cnc) agenda Map.empty chart
chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1
, passive=emptyPC
, offset =offset chart1+1
}
- in (PState pgf pinfo chart (TMap.singleton [] (Set.fromList agenda)), fmap (PState pgf pinfo chart2) acc)
+ in (PState pgf cnc chart (TMap.singleton [] (Set.fromList agenda)), fmap (PState pgf cnc chart2) acc)
where
- type2fcats (DTyp _ cat _) = case Map.lookup cat (startCats pinfo) of
+ type2fcats (DTyp _ cat _) = case Map.lookup cat (startCats cnc) of
Just (s,e,labels) -> range (s,e)
Nothing -> []
@@ -149,15 +146,15 @@ recoveryStates open_types (EState pgf pinfo chart) =
-- limited by the category specified, which is usually
-- the same as the startup category.
extractTrees :: ParseState -> Type -> [Tree]
-extractTrees (PState pgf pinfo chart items) ty@(DTyp _ start _) =
+extractTrees (PState pgf cnc chart items) ty@(DTyp _ start _) =
nubsort [e1 | e <- exps, Right e1 <- [checkExpr pgf e ty]]
where
(mb_agenda,acc) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda
- (_,st) = process Nothing (\_ _ -> id) (sequences pinfo) (functions pinfo) agenda () chart
+ (_,st) = process Nothing (\_ _ -> id) (sequences cnc) (functions cnc) agenda () chart
exps =
- case Map.lookup start (startCats pinfo) of
+ case Map.lookup start (startCats cnc) of
Just (s,e,lbls) -> do cat <- range (s,e)
lbl <- indices lbls
Just fid <- [lookupPC (PK cat lbl 0) (passive st)]
@@ -167,10 +164,10 @@ extractTrees (PState pgf pinfo chart items) ty@(DTyp _ start _) =
Nothing -> mzero
go rec fcat' (d,fcat)
- | fcat < totalCats pinfo = return (Set.empty,EMeta (fcat'*10+d)) -- FIXME: here we assume that every rule has at most 10 arguments
+ | fcat < totalCats cnc = return (Set.empty,EMeta (fcat'*10+d)) -- FIXME: here we assume that every rule has at most 10 arguments
| Set.member fcat rec = mzero
| otherwise = foldForest (\funid args trees ->
- do let FFun fn lins = functions pinfo ! funid
+ do let FFun fn lins = functions cnc ! funid
args <- mapM (go (Set.insert fcat rec) fcat) (zip [0..] args)
check_ho_fun fn args
`mplus`
@@ -348,7 +345,7 @@ foldForest f g b fcat forest =
-- | An abstract data type whose values represent
-- the current state in an incremental parser.
-data ParseState = PState PGF ParserInfo Chart (TMap.TrieMap String (Set.Set Active))
+data ParseState = PState PGF Concr Chart (TMap.TrieMap String (Set.Set Active))
data Chart
= Chart
@@ -367,4 +364,4 @@ data Chart
-- | An abstract data type whose values represent
-- the state in an incremental parser after an error.
-data ErrorState = EState PGF ParserInfo Chart
+data ErrorState = EState PGF Concr Chart
diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs
new file mode 100644
index 000000000..2f92dd8e0
--- /dev/null
+++ b/src/runtime/haskell/PGF/Printer.hs
@@ -0,0 +1,89 @@
+module PGF.Printer (ppPGF,ppCat,ppFun) where
+
+import PGF.CId
+import PGF.Data
+import PGF.Macros
+
+import GF.Data.Operations
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.IntMap as IntMap
+import Data.List
+import Data.Array.IArray
+import Data.Array.Unboxed
+import Text.PrettyPrint
+
+
+ppPGF :: PGF -> Doc
+ppPGF pgf = ppAbs (absname pgf) (abstract pgf) $$ ppAll ppCnc (concretes pgf)
+
+ppAbs :: Language -> Abstr -> Doc
+ppAbs name a = text "abstract" <+> ppCId name <+> char '{' $$
+ nest 2 (ppAll ppCat (cats a) $$
+ ppAll ppFun (funs a)) $$
+ char '}'
+
+ppCat :: CId -> [Hypo] -> Doc
+ppCat c hyps = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL ppHypo [] hyps))
+
+ppFun :: CId -> (Type,Int,[Equation]) -> Doc
+ppFun f (t,_,eqs) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t $$
+ if null eqs
+ then empty
+ else text "def" <+> vcat [let (scope,ds) = mapAccumL (ppPatt 9) [] patts
+ in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs]
+
+ppCnc :: Language -> Concr -> Doc
+ppCnc name cnc =
+ text "concrete" <+> ppCId name <+> char '{' $$
+ nest 2 (text "productions" $$
+ nest 2 (vcat [ppProduction (fcat,prod) | (fcat,set) <- IntMap.toList (productions cnc), prod <- Set.toList set]) $$
+ text "functions" $$
+ nest 2 (vcat (map ppFFun (assocs (functions cnc)))) $$
+ text "sequences" $$
+ nest 2 (vcat (map ppSeq (assocs (sequences cnc)))) $$
+ text "startcats" $$
+ nest 2 (vcat (map ppStartCat (Map.toList (startCats cnc))))) $$
+ char '}'
+
+ppProduction (fcat,FApply funid args) =
+ ppFCat fcat <+> text "->" <+> ppFunId funid <> brackets (hcat (punctuate comma (map ppFCat args)))
+ppProduction (fcat,FCoerce arg) =
+ ppFCat fcat <+> text "->" <+> char '_' <> brackets (ppFCat arg)
+ppProduction (fcat,FConst _ ss) =
+ ppFCat fcat <+> text "->" <+> ppStrs ss
+
+ppFFun (funid,FFun fun arr) =
+ ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun)
+
+ppSeq (seqid,seq) =
+ ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol (elems seq))
+
+ppStartCat (id,(start,end,labels)) =
+ ppCId id <+> text ":=" <+> (text "range " <+> brackets (ppFCat start <+> text ".." <+> ppFCat end) $$
+ text "labels" <+> brackets (vcat (map (text . show) (elems labels))))
+
+ppSymbol (FSymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
+ppSymbol (FSymLit d r) = char '<' <> int d <> comma <> int r <> char '>'
+ppSymbol (FSymKS ts) = ppStrs ts
+ppSymbol (FSymKP ts alts) = text "pre" <+> braces (hsep (punctuate semi (ppStrs ts : map ppAlt alts)))
+
+ppAlt (Alt ts ps) = ppStrs ts <+> char '/' <+> hsep (map (doubleQuotes . text) ps)
+
+ppStrs ss = doubleQuotes (hsep (map text ss))
+
+ppFCat fcat
+ | fcat == fcatString = text "CString"
+ | fcat == fcatInt = text "CInt"
+ | fcat == fcatFloat = text "CFloat"
+ | fcat == fcatVar = text "CVar"
+ | otherwise = char 'C' <> int fcat
+
+ppFunId funid = char 'F' <> int funid
+ppSeqId seqid = char 'S' <> int seqid
+
+-- Utilities
+
+ppAll :: (a -> b -> Doc) -> Map.Map a b -> Doc
+ppAll p m = vcat [ p k v | (k,v) <- Map.toList m]
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:19:49 +0000