GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-22 09:32:53 -06:00
Code Issues Packages Projects Releases Wiki Activity

cleanup the code of the PGF interpreter and polish the binary serialization to match the preliminary specification

Browse Source
This commit is contained in:
krasimir
2010-01-27 09:39:14 +00:00
parent a5a1d2bbe0
commit 3685595ece
20 changed files with 368 additions and 345 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
src/compiler/GF/Command/Commands.hs
View File

@@ -845,9 +845,9 @@ allCommands cod env@(pgf, mos) = Map.fromList [
-- - If lang has coding=other, and -to_utf8 is in opts, from_other is applied first. -- - If lang has coding=other, and -to_utf8 is in opts, from_other is applied first.
-- THIS DOES NOT WORK UNFORTUNATELY - can't use the grammar flag properly -- THIS DOES NOT WORK UNFORTUNATELY - can't use the grammar flag properly
unlexx opts lang = {- trace (unwords optsC) $ -} stringOps Nothing optsC where ---- unlexx opts lang = {- trace (unwords optsC) $ -} stringOps Nothing optsC where ----
optsC = case lookFlag pgf lang "coding" of optsC = case lookConcrFlag pgf (mkCId lang) (mkCId "coding") of
Just "utf8" -> filter (/="to_utf8") $ map prOpt opts Just (LStr "utf8") -> filter (/="to_utf8") $ map prOpt opts
Just other | isOpt "to_utf8" opts -> Just (LStr other) | isOpt "to_utf8" opts ->
let cod = ("from_" ++ other) let cod = ("from_" ++ other)
in cod : filter (/=cod) (map prOpt opts) in cod : filter (/=cod) (map prOpt opts)
_ -> map prOpt opts _ -> map prOpt opts
@@ -974,9 +974,6 @@ morphologyQuiz cod pgf ig typ = do
infinity :: Int infinity :: Int
infinity = 256 infinity = 256
lookFlag :: PGF -> String -> String -> Maybe String
lookFlag pgf lang flag = lookConcrFlag pgf (mkCId lang) (mkCId flag)
prFullFormLexicon :: Morpho -> String prFullFormLexicon :: Morpho -> String
prFullFormLexicon mo = prFullFormLexicon mo =
unlines (map prMorphoAnalysis (fullFormLexicon mo)) unlines (map prMorphoAnalysis (fullFormLexicon mo))

9
src/compiler/GF/Compile/Export.hs
View File

@@ -1,7 +1,6 @@
module GF.Compile.Export where module GF.Compile.Export where
import PGF.CId import PGF
import PGF.Data (PGF(..))
import PGF.Printer import PGF.Printer
import GF.Compile.PGFtoHaskell import GF.Compile.PGFtoHaskell
import GF.Compile.PGFtoProlog import GF.Compile.PGFtoProlog
@@ -48,17 +47,17 @@ exportPGF opts fmt pgf =
FmtRegExp -> single "rexp" regexpPrinter FmtRegExp -> single "rexp" regexpPrinter
FmtFA -> single "dot" slfGraphvizPrinter FmtFA -> single "dot" slfGraphvizPrinter
where where
name = fromMaybe (showCId (absname pgf)) (flag optName opts) name = fromMaybe (showCId (abstractName pgf)) (flag optName opts)
multi :: String -> (PGF -> String) -> [(FilePath,String)] multi :: String -> (PGF -> String) -> [(FilePath,String)]
multi ext pr = [(name <.> ext, pr pgf)] multi ext pr = [(name <.> ext, pr pgf)]
single :: String -> (PGF -> CId -> String) -> [(FilePath,String)] single :: String -> (PGF -> CId -> String) -> [(FilePath,String)]
single ext pr = [(showCId cnc <.> ext, pr pgf cnc) | cnc <- cncnames pgf] single ext pr = [(showCId cnc <.> ext, pr pgf cnc) | cnc <- languages pgf]
-- | Get the name of the concrete syntax to generate output from. -- | Get the name of the concrete syntax to generate output from.
-- FIXME: there should be an option to change this. -- FIXME: there should be an option to change this.
outputConcr :: PGF -> CId outputConcr :: PGF -> CId
outputConcr pgf = case cncnames pgf of outputConcr pgf = case languages pgf of
[] -> error "No concrete syntax." [] -> error "No concrete syntax."
cnc:_ -> cnc cnc:_ -> cnc

96
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -91,14 +91,14 @@ brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
case f (GrammarEnv last_id catSet seqSet funSet crcSet IntMap.empty) of case f (GrammarEnv last_id catSet seqSet funSet crcSet IntMap.empty) of
(GrammarEnv last_id catSet seqSet funSet crcSet topdown1) -> IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) topdown1 (GrammarEnv last_id catSet seqSet funSet crcSet topdown1) -> IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) topdown1
where where
optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | FApply funid args <- Set.toList ps]) optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | PApply funid args <- Set.toList ps])
where where
ff :: FunId -> [[FCat]] -> GrammarEnv -> GrammarEnv ff :: FunId -> [[FId]] -> GrammarEnv -> GrammarEnv
ff funid xs env ff funid xs env
| product (map Set.size ys) == count = | product (map Set.size ys) == count =
case List.mapAccumL (\env c -> addFCoercion env (Set.toList c)) env ys of case List.mapAccumL (\env c -> addFCoercion env (Set.toList c)) env ys of
(env,args) -> addProduction env cat (FApply funid args) (env,args) -> addProduction env cat (PApply funid args)
| otherwise = List.foldl (\env args -> addProduction env cat (FApply funid args)) env xs | otherwise = List.foldl (\env args -> addProduction env cat (PApply funid args)) env xs
where where
count = length xs count = length xs
ys = foldr (zipWith Set.insert) (repeat Set.empty) xs ys = foldr (zipWith Set.insert) (repeat Set.empty) xs
@@ -120,34 +120,34 @@ convertRule cnc_defs grammarEnv (PFRule fun args res ctypes ctype term) =
let [newCat] = getFCats env0 newCat' let [newCat] = getFCats env0 newCat'
(env1, newArgs) = List.mapAccumL (\env -> addFCoercion env . getFCats env) env0 newArgs' (env1, newArgs) = List.mapAccumL (\env -> addFCoercion env . getFCats env) env0 newArgs'
(env2,funid) = addFFun env1 (FFun fun (mkArray lins)) (env2,funid) = addCncFun env1 (CncFun fun (mkArray lins))
in addProduction env2 newCat (FApply funid newArgs) in addProduction env2 newCat (PApply funid newArgs)
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- Branch monad -- Branch monad
newtype BranchM a = BM (forall b . (a -> ([ProtoFCat],[FSymbol]) -> Branch b) -> ([ProtoFCat],[FSymbol]) -> Branch b) newtype BranchM a = BM (forall b . (a -> ([ProtoFCat],[Symbol]) -> Branch b) -> ([ProtoFCat],[Symbol]) -> Branch b)
instance Monad BranchM where instance Monad BranchM where
return a = BM (\c s -> c a s) return a = BM (\c s -> c a s)
BM m >>= k = BM (\c s -> m (\a s -> unBM (k a) c s) s) BM m >>= k = BM (\c s -> m (\a s -> unBM (k a) c s) s)
where unBM (BM m) = m where unBM (BM m) = m
instance MonadState ([ProtoFCat],[FSymbol]) BranchM where instance MonadState ([ProtoFCat],[Symbol]) BranchM where
get = BM (\c s -> c s s) get = BM (\c s -> c s s)
put s = BM (\c _ -> c () s) put s = BM (\c _ -> c () s)
instance Functor BranchM where instance Functor BranchM where
fmap f (BM m) = BM (\c s -> m (c . f) s) fmap f (BM m) = BM (\c s -> m (c . f) s)
runBranchM :: BranchM (Value a) -> ([ProtoFCat],[FSymbol]) -> Branch a runBranchM :: BranchM (Value a) -> ([ProtoFCat],[Symbol]) -> Branch a
runBranchM (BM m) s = m (\v s -> Return v) s runBranchM (BM m) s = m (\v s -> Return v) s
variants :: [a] -> BranchM a variants :: [a] -> BranchM a
variants xs = BM (\c s -> Variant [c x s | x <- xs]) variants xs = BM (\c s -> Variant [c x s | x <- xs])
choices :: Int -> FPath -> BranchM FIndex choices :: Int -> FPath -> BranchM LIndex
choices nr path = BM (\c s -> let (args,_) = s choices nr path = BM (\c s -> let (args,_) = s
PFCat _ _ _ tcs = args !! nr PFCat _ _ _ tcs = args !! nr
in case fromMaybe (error "evalTerm: wrong path") (lookup path tcs) of in case fromMaybe (error "evalTerm: wrong path") (lookup path tcs) of
@@ -172,8 +172,8 @@ mkRecord xs = BM (\c -> foldl (\c (BM m) bs s -> c (m (\v s -> Return v) s : bs)
type CnvMonad a = BranchM a type CnvMonad a = BranchM a
type FPath = [FIndex] type FPath = [LIndex]
data ProtoFCat = PFCat Int CId [FPath] [(FPath,[FIndex])] data ProtoFCat = PFCat Int CId [FPath] [(FPath,[LIndex])]
type Env = (ProtoFCat, [ProtoFCat]) type Env = (ProtoFCat, [ProtoFCat])
data ProtoFRule = PFRule CId {- function -} data ProtoFRule = PFRule CId {- function -}
[(Int,CId)] {- argument types: context size and category -} [(Int,CId)] {- argument types: context size and category -}
@@ -210,7 +210,7 @@ data Branch a
data Value a data Value a
= Rec [Branch a] = Rec [Branch a]
| Str a | Str a
| Con FIndex | Con LIndex
go' :: Branch SeqId -> FPath -> [SeqId] -> BacktrackM Env [SeqId] go' :: Branch SeqId -> FPath -> [SeqId] -> BacktrackM Env [SeqId]
@@ -226,7 +226,7 @@ go (Rec xs) path ss = foldM (\ss (lbl,b) -> go' b (lbl:path) ss) ss (reverse
go (Str seqid) path ss = return (seqid : ss) go (Str seqid) path ss = return (seqid : ss)
go (Con i) path ss = restrictHead path i >> return ss go (Con i) path ss = restrictHead path i >> return ss
addSequences' :: GrammarEnv -> Branch [FSymbol] -> (GrammarEnv, Branch SeqId) addSequences' :: GrammarEnv -> Branch [Symbol] -> (GrammarEnv, Branch SeqId)
addSequences' env (Case nr path bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs addSequences' env (Case nr path bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs
in (env1,Case nr path bs1) in (env1,Case nr path bs1)
addSequences' env (Variant bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs addSequences' env (Variant bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs
@@ -234,7 +234,7 @@ addSequences' env (Variant bs) = let (env1,bs1) = List.mapAccumL addSequenc
addSequences' env (Return v) = let (env1,v1) = addSequences env v addSequences' env (Return v) = let (env1,v1) = addSequences env v
in (env1,Return v1) in (env1,Return v1)
addSequences :: GrammarEnv -> Value [FSymbol] -> (GrammarEnv, Value SeqId) addSequences :: GrammarEnv -> Value [Symbol] -> (GrammarEnv, Value SeqId)
addSequences env (Rec vs) = let (env1,vs1) = List.mapAccumL addSequences' env vs addSequences env (Rec vs) = let (env1,vs1) = List.mapAccumL addSequences' env vs
in (env1,Rec vs1) in (env1,Rec vs1)
addSequences env (Str lin) = let (env1,seqid) = addFSeq env (optimizeLin lin) addSequences env (Str lin) = let (env1,seqid) = addFSeq env (optimizeLin lin)
@@ -243,17 +243,17 @@ addSequences env (Con i) = (env,Con i)
optimizeLin [] = [] optimizeLin [] = []
optimizeLin lin@(FSymKS _ : _) = optimizeLin lin@(SymKS _ : _) =
let (ts,lin') = getRest lin let (ts,lin') = getRest lin
in FSymKS ts : optimizeLin lin' in SymKS ts : optimizeLin lin'
where where
getRest (FSymKS ts : lin) = let (ts1,lin') = getRest lin getRest (SymKS ts : lin) = let (ts1,lin') = getRest lin
in (ts++ts1,lin') in (ts++ts1,lin')
getRest lin = ([],lin) getRest lin = ([],lin)
optimizeLin (sym : lin) = sym : optimizeLin lin optimizeLin (sym : lin) = sym : optimizeLin lin
convertTerm :: TermMap -> FPath -> Term -> Term -> CnvMonad (Value [FSymbol]) convertTerm :: TermMap -> FPath -> Term -> Term -> CnvMonad (Value [Symbol])
convertTerm cnc_defs sel ctype (V nr) = convertArg ctype nr (reverse sel) convertTerm cnc_defs sel ctype (V nr) = convertArg ctype nr (reverse sel)
convertTerm cnc_defs sel ctype (C nr) = convertCon ctype nr (reverse sel) convertTerm cnc_defs sel ctype (C nr) = convertCon ctype nr (reverse sel)
convertTerm cnc_defs sel ctype (R record) = convertRec cnc_defs sel ctype record convertTerm cnc_defs sel ctype (R record) = convertRec cnc_defs sel ctype record
@@ -263,8 +263,8 @@ convertTerm cnc_defs sel ctype (FV vars) = do term <- variants vars
convertTerm cnc_defs sel ctype term convertTerm cnc_defs sel ctype term
convertTerm cnc_defs sel ctype (S ts) = do vs <- mapM (convertTerm cnc_defs sel ctype) ts convertTerm cnc_defs sel ctype (S ts) = do vs <- mapM (convertTerm cnc_defs sel ctype) ts
return (Str (concat [s | Str s <- vs])) return (Str (concat [s | Str s <- vs]))
convertTerm cnc_defs sel ctype (K (KS t)) = return (Str [FSymKS [t]]) convertTerm cnc_defs sel ctype (K (KS t)) = return (Str [SymKS [t]])
convertTerm cnc_defs sel ctype (K (KP s v))=return (Str [FSymKP s v]) convertTerm cnc_defs sel ctype (K (KP s v))=return (Str [SymKP s v])
convertTerm cnc_defs sel ctype (F id) = case Map.lookup id cnc_defs of convertTerm cnc_defs sel ctype (F id) = case Map.lookup id cnc_defs of
Just term -> convertTerm cnc_defs sel ctype term Just term -> convertTerm cnc_defs sel ctype term
Nothing -> error ("unknown id " ++ showCId id) Nothing -> error ("unknown id " ++ showCId id)
@@ -277,7 +277,7 @@ convertTerm cnc_defs sel ctype (W s t) = do
convertRec cnc_defs sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss] convertRec cnc_defs sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss]
convertTerm cnc_defs sel ctype x = error ("convertTerm ("++show x++")") convertTerm cnc_defs sel ctype x = error ("convertTerm ("++show x++")")
convertArg :: Term -> Int -> FPath -> CnvMonad (Value [FSymbol]) convertArg :: Term -> Int -> FPath -> CnvMonad (Value [Symbol])
convertArg (R ctypes) nr path = do convertArg (R ctypes) nr path = do
mkRecord (zipWith (\lbl ctype -> convertArg ctype nr (lbl:path)) [0..] ctypes) mkRecord (zipWith (\lbl ctype -> convertArg ctype nr (lbl:path)) [0..] ctypes)
convertArg (C max) nr path = do convertArg (C max) nr path = do
@@ -287,8 +287,8 @@ convertArg (S _) nr path = do
(args,_) <- get (args,_) <- get
let PFCat _ cat rcs tcs = args !! nr let PFCat _ cat rcs tcs = args !! nr
l = index path rcs 0 l = index path rcs 0
sym | isLiteralCat cat = FSymLit nr l sym | isLiteralCat cat = SymLit nr l
| otherwise = FSymCat nr l | otherwise = SymCat nr l
return (Str [sym]) return (Str [sym])
where where
index lbl' (lbl:lbls) idx index lbl' (lbl:lbls) idx
@@ -307,7 +307,7 @@ convertRec cnc_defs (index:sub_sel) ctype record =
------------------------------------------------------------ ------------------------------------------------------------
-- eval a term to ground terms -- eval a term to ground terms
evalTerm :: TermMap -> FPath -> Term -> CnvMonad FIndex evalTerm :: TermMap -> FPath -> Term -> CnvMonad LIndex
evalTerm cnc_defs path (V nr) = choices nr (reverse path) evalTerm cnc_defs path (V nr) = choices nr (reverse path)
evalTerm cnc_defs path (C nr) = return nr evalTerm cnc_defs path (C nr) = return nr
evalTerm cnc_defs path (R record) = case path of evalTerm cnc_defs path (R record) = case path of
@@ -325,10 +325,10 @@ evalTerm cnc_defs path x = error ("evalTerm ("++show x++")")
-- GrammarEnv -- GrammarEnv
data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet CoerceSet (IntMap.IntMap (Set.Set Production)) data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet CoerceSet (IntMap.IntMap (Set.Set Production))
type CatSet = IntMap.IntMap (Map.Map CId (FCat,FCat,[Int],Array FIndex String)) type CatSet = IntMap.IntMap (Map.Map CId (FId,FId,[Int],Array LIndex String))
type SeqSet = Map.Map FSeq SeqId type SeqSet = Map.Map Sequence SeqId
type FunSet = Map.Map FFun FunId type FunSet = Map.Map CncFun FunId
type CoerceSet= Map.Map [FCat] FCat type CoerceSet= Map.Map [FId] FId
emptyGrammarEnv cnc_defs lincats params = emptyGrammarEnv cnc_defs lincats params =
let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats
@@ -373,14 +373,14 @@ expandHOAS abs_defs cnc_defs lincats lindefs env =
-- add one PMCFG function for each high-order type: _B : Cat -> Var -> ... -> Var -> HoCat -- add one PMCFG function for each high-order type: _B : Cat -> Var -> ... -> Var -> HoCat
add_hoFun env (n,cat) = add_hoFun env (n,cat) =
let linRec = [[FSymCat 0 i] | i <- case arg of {PFCat _ _ rcs _ -> [0..length rcs-1]}] ++ let linRec = [[SymCat 0 i] | i <- case arg of {PFCat _ _ rcs _ -> [0..length rcs-1]}] ++
[[FSymLit i 0] | i <- [1..n]] [[SymLit i 0] | i <- [1..n]]
(env1,lins) = List.mapAccumL addFSeq env linRec (env1,lins) = List.mapAccumL addFSeq env linRec
newLinRec = mkArray lins newLinRec = mkArray lins
(env2,funid) = addFFun env1 (FFun _B newLinRec) (env2,funid) = addCncFun env1 (CncFun _B newLinRec)
env3 = foldl (\env (arg,res) -> addProduction env res (FApply funid (arg : replicate n fcatVar))) env3 = foldl (\env (arg,res) -> addProduction env res (PApply funid (arg : replicate n fcatVar)))
env2 env2
(zip (getFCats env2 arg) (getFCats env2 res)) (zip (getFCats env2 arg) (getFCats env2 res))
in env3 in env3
@@ -405,11 +405,11 @@ expandHOAS abs_defs cnc_defs lincats lindefs env =
Nothing -> error $ "No lincat for " ++ showCId cat Nothing -> error $ "No lincat for " ++ showCId cat
Just ctype -> ctype Just ctype -> ctype
addProduction :: GrammarEnv -> FCat -> Production -> GrammarEnv addProduction :: GrammarEnv -> FId -> Production -> GrammarEnv
addProduction (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) cat p = addProduction (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) cat p =
GrammarEnv last_id catSet seqSet funSet crcSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet) GrammarEnv last_id catSet seqSet funSet crcSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet)
addFSeq :: GrammarEnv -> [FSymbol] -> (GrammarEnv,SeqId) addFSeq :: GrammarEnv -> [Symbol] -> (GrammarEnv,SeqId)
addFSeq env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) lst = addFSeq env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) lst =
case Map.lookup seq seqSet of case Map.lookup seq seqSet of
Just id -> (env,id) Just id -> (env,id)
@@ -418,14 +418,14 @@ addFSeq env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) lst =
where where
seq = mkArray lst seq = mkArray lst
addFFun :: GrammarEnv -> FFun -> (GrammarEnv,FunId) addCncFun :: GrammarEnv -> CncFun -> (GrammarEnv,FunId)
addFFun env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) fun = addCncFun env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) fun =
case Map.lookup fun funSet of case Map.lookup fun funSet of
Just id -> (env,id) Just id -> (env,id)
Nothing -> let !last_funid = Map.size funSet Nothing -> let !last_funid = Map.size funSet
in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) crcSet prodSet,last_funid) in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) crcSet prodSet,last_funid)
addFCoercion :: GrammarEnv -> [FCat] -> (GrammarEnv,FCat) addFCoercion :: GrammarEnv -> [FId] -> (GrammarEnv,FId)
addFCoercion env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) sub_fcats = addFCoercion env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) sub_fcats =
case sub_fcats of case sub_fcats of
[fcat] -> (env,fcat) [fcat] -> (env,fcat)
@@ -434,24 +434,24 @@ addFCoercion env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) sub_fc
Nothing -> let !fcat = last_id+1 Nothing -> let !fcat = last_id+1
in (GrammarEnv fcat catSet seqSet funSet (Map.insert sub_fcats fcat crcSet) prodSet,fcat) in (GrammarEnv fcat catSet seqSet funSet (Map.insert sub_fcats fcat crcSet) prodSet,fcat)
getParserInfo :: Map.Map CId String -> Map.Map CId String -> GrammarEnv -> Concr getParserInfo :: Map.Map CId Literal -> Map.Map CId String -> GrammarEnv -> Concr
getParserInfo flags printnames (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = getParserInfo flags printnames (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
Concr { cflags = flags Concr { cflags = flags
, printnames = printnames , printnames = printnames
, functions = mkArray funSet , cncfuns = mkArray funSet
, sequences = mkArray seqSet , sequences = mkArray seqSet
, productions = IntMap.union prodSet coercions , productions = IntMap.union prodSet coercions
, pproductions = IntMap.empty , pproductions = IntMap.empty
, lproductions = Map.empty , lproductions = Map.empty
, startCats = maybe Map.empty (Map.map (\(start,end,_,lbls) -> (start,end,lbls))) (IntMap.lookup 0 catSet) , cnccats = maybe Map.empty (Map.map (\(start,end,_,lbls) -> (CncCat start end lbls))) (IntMap.lookup 0 catSet)
, totalCats = last_id+1 , totalCats = last_id+1
} }
where where
mkArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] mkArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
coercions = IntMap.fromList [(fcat,Set.fromList (map FCoerce sub_fcats)) | (sub_fcats,fcat) <- Map.toList crcSet] coercions = IntMap.fromList [(fcat,Set.fromList (map PCoerce sub_fcats)) | (sub_fcats,fcat) <- Map.toList crcSet]
getFCats :: GrammarEnv -> ProtoFCat -> [FCat] getFCats :: GrammarEnv -> ProtoFCat -> [FId]
getFCats (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat rcs tcs) = getFCats (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat rcs tcs) =
case IntMap.lookup n catSet >>= Map.lookup cat of case IntMap.lookup n catSet >>= Map.lookup cat of
Just (start,end,ms,_) -> reverse (solutions (variants ms tcs start) ()) Just (start,end,ms,_) -> reverse (solutions (variants ms tcs start) ())
@@ -464,19 +464,19 @@ getFCats (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat r
------------------------------------------------------------ ------------------------------------------------------------
-- updating the MCF rule -- updating the MCF rule
restrictArg :: FIndex -> FPath -> FIndex -> BacktrackM Env () restrictArg :: LIndex -> FPath -> LIndex -> BacktrackM Env ()
restrictArg nr path index = do restrictArg nr path index = do
(head, args) <- get (head, args) <- get
args' <- updateNthM (restrictProtoFCat path index) nr args args' <- updateNthM (restrictProtoFCat path index) nr args
put (head, args') put (head, args')
restrictHead :: FPath -> FIndex -> BacktrackM Env () restrictHead :: FPath -> LIndex -> BacktrackM Env ()
restrictHead path term restrictHead path term
= do (head, args) <- get = do (head, args) <- get
head' <- restrictProtoFCat path term head head' <- restrictProtoFCat path term head
put (head', args) put (head', args)
restrictProtoFCat :: FPath -> FIndex -> ProtoFCat -> BacktrackM Env ProtoFCat restrictProtoFCat :: FPath -> LIndex -> ProtoFCat -> BacktrackM Env ProtoFCat
restrictProtoFCat path0 index0 (PFCat n cat rcs tcs) = do restrictProtoFCat path0 index0 (PFCat n cat rcs tcs) = do
tcs <- addConstraint tcs tcs <- addConstraint tcs
return (PFCat n cat rcs tcs) return (PFCat n cat rcs tcs)

13
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -52,14 +52,13 @@ canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do
then putStrLn (render (vcat (map (ppModule Qualified) (M.modules cgr)))) then putStrLn (render (vcat (map (ppModule Qualified) (M.modules cgr))))
else return () else return ()
cncs <- sequence [mkConcr lang (i2i lang) mo | (lang,mo) <- cms] cncs <- sequence [mkConcr lang (i2i lang) mo | (lang,mo) <- cms]
return $ updateProductionIndices (D.PGF an cns gflags abs (Map.fromList cncs)) return $ updateProductionIndices (D.PGF gflags an abs (Map.fromList cncs))
where where
-- abstract -- abstract
an = (i2i a) an = (i2i a)
cns = map (i2i . fst) cms abs = D.Abstr aflags funs cats Map.empty
abs = D.Abstr aflags funs cats catfuns
gflags = Map.empty gflags = Map.empty
aflags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF (M.flags abm)] aflags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags abm)]
mkDef (Just eqs) = [C.Equ ps' (mkExp scope' e) | (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] mkDef (Just eqs) = [C.Equ ps' (mkExp scope' e) | (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
mkDef Nothing = [] mkDef Nothing = []
@@ -85,7 +84,7 @@ canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do
return (lang, cnc) return (lang, cnc)
where where
js = tree2list (M.jments mo) js = tree2list (M.jments mo)
flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF (M.flags mo)] flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags mo)]
utf = id -- trace (show lang0 +++ show flags) $ utf = id -- trace (show lang0 +++ show flags) $
-- if moduleFlag optEncoding (moduleOptions (M.flags mo)) == UTF_8 -- if moduleFlag optEncoding (moduleOptions (M.flags mo)) == UTF_8
-- then id else id -- then id else id
@@ -132,7 +131,7 @@ mkExp scope t = case GM.termForm t of
Vr x -> case lookup x (zip scope [0..]) of Vr x -> case lookup x (zip scope [0..]) of
Just i -> foldl C.EApp (C.EVar i) args Just i -> foldl C.EApp (C.EVar i) args
Nothing -> foldl C.EApp (C.EMeta 0) args Nothing -> foldl C.EApp (C.EMeta 0) args
EInt i -> C.ELit (C.LInt i) EInt i -> C.ELit (C.LInt (fromIntegral i))
EFloat f -> C.ELit (C.LFlt f) EFloat f -> C.ELit (C.LFlt f)
K s -> C.ELit (C.LStr s) K s -> C.ELit (C.LStr s)
Meta i -> C.EMeta i Meta i -> C.EMeta i
@@ -144,7 +143,7 @@ mkPatt scope p =
in (scope',C.PApp (i2i c) ps') in (scope',C.PApp (i2i c) ps')
A.PV x -> (x:scope,C.PVar (i2i x)) A.PV x -> (x:scope,C.PVar (i2i x))
A.PW -> ( scope,C.PWild) A.PW -> ( scope,C.PWild)
A.PInt i -> ( scope,C.PLit (C.LInt i)) A.PInt i -> ( scope,C.PLit (C.LInt (fromIntegral i)))
A.PFloat f -> ( scope,C.PLit (C.LFlt f)) A.PFloat f -> ( scope,C.PLit (C.LFlt f))
A.PString s -> ( scope,C.PLit (C.LStr s)) A.PString s -> ( scope,C.PLit (C.LStr s))

32
src/compiler/GF/Compile/PGFtoJS.hs
View File

@@ -39,21 +39,25 @@ absdef2js (f,(typ,_,_)) =
let (args,cat) = M.catSkeleton typ in let (args,cat) = M.catSkeleton typ in
JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)]) JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])
lit2js (LStr s) = JS.EStr s
lit2js (LInt n) = JS.EInt n
lit2js (LFlt d) = JS.EDbl d
concrete2js :: (CId,Concr) -> JS.Property concrete2js :: (CId,Concr) -> JS.Property
concrete2js (c,cnc) = concrete2js (c,cnc) =
JS.Prop l (new "GFConcrete" [mapToJSObj JS.EStr $ cflags cnc, JS.Prop l (new "GFConcrete" [mapToJSObj (lit2js) $ cflags cnc,
JS.EObj $ [JS.Prop (JS.IntPropName cat) (JS.EArray (map frule2js (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)], JS.EObj $ [JS.Prop (JS.IntPropName cat) (JS.EArray (map frule2js (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)],
JS.EArray $ (map ffun2js (Array.elems (functions cnc))), JS.EArray $ (map ffun2js (Array.elems (cncfuns cnc))),
JS.EArray $ (map seq2js (Array.elems (sequences cnc))), JS.EArray $ (map seq2js (Array.elems (sequences cnc))),
JS.EObj $ map cats (Map.assocs (startCats cnc)), JS.EObj $ map cats (Map.assocs (cnccats cnc)),
JS.EInt (totalCats cnc)]) JS.EInt (totalCats cnc)])
where where
l = JS.IdentPropName (JS.Ident (showCId c)) l = JS.IdentPropName (JS.Ident (showCId c))
litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])] JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])]
cats (c,(start,end,_)) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EObj [JS.Prop (JS.IdentPropName (JS.Ident "s")) (JS.EInt start) cats (c,CncCat start end _) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EObj [JS.Prop (JS.IdentPropName (JS.Ident "s")) (JS.EInt start)
,JS.Prop (JS.IdentPropName (JS.Ident "e")) (JS.EInt end)]) ,JS.Prop (JS.IdentPropName (JS.Ident "e")) (JS.EInt end)])
cncdef2js :: String -> String -> (CId,Term) -> JS.Property cncdef2js :: String -> String -> (CId,Term) -> JS.Property
cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)]) cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)])
@@ -92,19 +96,19 @@ children :: JS.Ident
children = JS.Ident "cs" children = JS.Ident "cs"
frule2js :: Production -> JS.Expr frule2js :: Production -> JS.Expr
frule2js (FApply funid args) = new "Rule" [JS.EInt funid, JS.EArray (map JS.EInt args)] frule2js (PApply funid args) = new "Rule" [JS.EInt funid, JS.EArray (map JS.EInt args)]
frule2js (FCoerce arg) = new "Coerce" [JS.EInt arg] frule2js (PCoerce arg) = new "Coerce" [JS.EInt arg]
ffun2js (FFun f lins) = new "FFun" [JS.EStr (showCId f), JS.EArray (map JS.EInt (Array.elems lins))] ffun2js (CncFun f lins) = new "CncFun" [JS.EStr (showCId f), JS.EArray (map JS.EInt (Array.elems lins))]
seq2js :: Array.Array FIndex FSymbol -> JS.Expr seq2js :: Array.Array DotPos Symbol -> JS.Expr
seq2js seq = JS.EArray [sym2js s | s <- Array.elems seq] seq2js seq = JS.EArray [sym2js s | s <- Array.elems seq]
sym2js :: FSymbol -> JS.Expr sym2js :: Symbol -> JS.Expr
sym2js (FSymCat n l) = new "Arg" [JS.EInt n, JS.EInt l] sym2js (SymCat n l) = new "Arg" [JS.EInt n, JS.EInt l]
sym2js (FSymLit n l) = new "Lit" [JS.EInt n, JS.EInt l] sym2js (SymLit n l) = new "Lit" [JS.EInt n, JS.EInt l]
sym2js (FSymKS ts) = new "KS" (map JS.EStr ts) sym2js (SymKS ts) = new "KS" (map JS.EStr ts)
sym2js (FSymKP ts alts) = new "KP" [JS.EArray (map JS.EStr ts), JS.EArray (map alt2js alts)] sym2js (SymKP ts alts) = new "KP" [JS.EArray (map JS.EStr ts), JS.EArray (map alt2js alts)]
alt2js (Alt ps ts) = new "Alt" [JS.EArray (map JS.EStr ps), JS.EArray (map JS.EStr ts)] alt2js (Alt ps ts) = new "Alt" [JS.EArray (map JS.EStr ps), JS.EArray (map JS.EStr ts)]

6
src/compiler/GF/Compile/PGFtoProlog.hs
View File

@@ -28,17 +28,15 @@ grammar2prolog_abs = {- encodeUTF8 . -} foldr (++++) [] . pgf2clauses_abs
pgf2clauses :: PGF -> [String] pgf2clauses :: PGF -> [String]
pgf2clauses (PGF absname cncnames gflags abstract concretes) = pgf2clauses (PGF gflags absname abstract concretes) =
[":- " ++ plFact "module" [plp absname, "[]"]] ++ [":- " ++ plFact "module" [plp absname, "[]"]] ++
clauseHeader "%% concrete(?Module)"
[plFact "concrete" [plp cncname] | cncname <- cncnames] ++
clauseHeader "%% flag(?Flag, ?Value): global flags" clauseHeader "%% flag(?Flag, ?Value): global flags"
(map (plpFact2 "flag") (Map.assocs gflags)) ++ (map (plpFact2 "flag") (Map.assocs gflags)) ++
plAbstract (absname, abstract) ++ plAbstract (absname, abstract) ++
concatMap plConcrete (Map.assocs concretes) concatMap plConcrete (Map.assocs concretes)
pgf2clauses_abs :: PGF -> [String] pgf2clauses_abs :: PGF -> [String]
pgf2clauses_abs (PGF absname _cncnames gflags abstract _concretes) = pgf2clauses_abs (PGF gflags absname abstract _concretes) =
[":- " ++ plFact "module" [plp absname, "[]"]] ++ [":- " ++ plFact "module" [plp absname, "[]"]] ++
clauseHeader "%% flag(?Flag, ?Value): global flags" clauseHeader "%% flag(?Flag, ?Value): global flags"
(map (plpFact2 "flag") (Map.assocs gflags)) ++ (map (plpFact2 "flag") (Map.assocs gflags)) ++

3
src/compiler/GF/Speech/GSL.hs
View File

@@ -14,8 +14,7 @@ import GF.Speech.SRG
import GF.Speech.RegExp import GF.Speech.RegExp
import GF.Infra.Option import GF.Infra.Option
import GF.Infra.Ident import GF.Infra.Ident
import PGF.CId import PGF
import PGF.Data
import Data.Char (toUpper,toLower) import Data.Char (toUpper,toLower)
import Data.List (partition) import Data.List (partition)

60
src/compiler/GF/Speech/PGFToCFG.hs
View File

@@ -10,7 +10,7 @@ import PGF.CId
import PGF.Data as PGF import PGF.Data as PGF
import PGF.Macros import PGF.Macros
import GF.Infra.Ident import GF.Infra.Ident
import GF.Speech.CFG import GF.Speech.CFG hiding (Symbol)
import Data.Array.IArray as Array import Data.Array.IArray as Array
import Data.List import Data.List
@@ -32,36 +32,36 @@ type Profile = [Int]
pgfToCFG :: PGF pgfToCFG :: PGF
-> CId -- ^ Concrete syntax name -> CId -- ^ Concrete syntax name
-> CFG -> CFG
pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ concatMap fruleToCFRule rules) pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ concatMap ruleToCFRule rules)
where where
cnc = lookConcr pgf lang cnc = lookConcr pgf lang
rules :: [(FCat,Production)] rules :: [(FId,Production)]
rules = [(fcat,prod) | (fcat,set) <- IntMap.toList (PGF.pproductions cnc) rules = [(fcat,prod) | (fcat,set) <- IntMap.toList (PGF.pproductions cnc)
, prod <- Set.toList set] , prod <- Set.toList set]
fcatCats :: Map FCat Cat fcatCats :: Map FId Cat
fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i) fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i)
| (c,(s,e,lbls)) <- Map.toList (startCats cnc), | (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
(fc,i) <- zip (range (s,e)) [1..]] (fc,i) <- zip (range (s,e)) [1..]]
fcatCat :: FCat -> Cat fcatCat :: FId -> Cat
fcatCat c = Map.findWithDefault ("Unknown_" ++ show c) c fcatCats fcatCat c = Map.findWithDefault ("Unknown_" ++ show c) c fcatCats
fcatToCat :: FCat -> FIndex -> Cat fcatToCat :: FId -> LIndex -> Cat
fcatToCat c l = fcatCat c ++ row fcatToCat c l = fcatCat c ++ row
where row = if catLinArity c == 1 then "" else "_" ++ show l where row = if catLinArity c == 1 then "" else "_" ++ show l
-- gets the number of fields in the lincat for the given category -- gets the number of fields in the lincat for the given category
catLinArity :: FCat -> Int catLinArity :: FId -> Int
catLinArity c = maximum (1:[rangeSize (bounds rhs) | (FFun _ rhs, _) <- topdownRules c]) catLinArity c = maximum (1:[rangeSize (bounds rhs) | (CncFun _ rhs, _) <- topdownRules c])
topdownRules cat = f cat [] topdownRules cat = f cat []
where where
f cat rules = maybe rules (Set.fold g rules) (IntMap.lookup cat (pproductions cnc)) f cat rules = maybe rules (Set.fold g rules) (IntMap.lookup cat (pproductions cnc))
g (FApply funid args) rules = (functions cnc ! funid,args) : rules g (PApply funid args) rules = (cncfuns cnc ! funid,args) : rules
g (FCoerce cat) rules = f cat rules g (PCoerce cat) rules = f cat rules
extCats :: Set Cat extCats :: Set Cat
@@ -69,40 +69,40 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
startRules :: [CFRule] startRules :: [CFRule]
startRules = [CFRule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0) startRules = [CFRule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0)
| (c,(s,e,lbls)) <- Map.toList (startCats cnc), | (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
fc <- range (s,e), not (isLiteralFCat fc), fc <- range (s,e), not (isLiteralFCat fc),
r <- [0..catLinArity fc-1]] r <- [0..catLinArity fc-1]]
fruleToCFRule :: (FCat,Production) -> [CFRule] ruleToCFRule :: (FId,Production) -> [CFRule]
fruleToCFRule (c,FApply funid args) = ruleToCFRule (c,PApply funid args) =
[CFRule (fcatToCat c l) (mkRhs row) (profilesToTerm [fixProfile row n | n <- [0..length args-1]]) [CFRule (fcatToCat c l) (mkRhs row) (profilesToTerm [fixProfile row n | n <- [0..length args-1]])
| (l,seqid) <- Array.assocs rhs | (l,seqid) <- Array.assocs rhs
, let row = sequences cnc ! seqid , let row = sequences cnc ! seqid
, not (containsLiterals row)] , not (containsLiterals row)]
where where
FFun f rhs = functions cnc ! funid CncFun f rhs = cncfuns cnc ! funid
mkRhs :: Array FPointPos FSymbol -> [CFSymbol] mkRhs :: Array DotPos Symbol -> [CFSymbol]
mkRhs = concatMap fsymbolToSymbol . Array.elems mkRhs = concatMap symbolToCFSymbol . Array.elems
containsLiterals :: Array FPointPos FSymbol -> Bool containsLiterals :: Array DotPos Symbol -> Bool
containsLiterals row = any isLiteralFCat [args!!n | FSymCat n _ <- Array.elems row] || containsLiterals row = any isLiteralFCat [args!!n | SymCat n _ <- Array.elems row] ||
not (null [n | FSymLit n _ <- Array.elems row]) -- only this is needed for PMCFG. not (null [n | SymLit n _ <- Array.elems row]) -- only this is needed for PMCFG.
-- The first line is for backward compat. -- The first line is for backward compat.
fsymbolToSymbol :: FSymbol -> [CFSymbol] symbolToCFSymbol :: Symbol -> [CFSymbol]
fsymbolToSymbol (FSymCat n l) = [NonTerminal (fcatToCat (args!!n) l)] symbolToCFSymbol (SymCat n l) = [NonTerminal (fcatToCat (args!!n) l)]
fsymbolToSymbol (FSymLit n l) = [NonTerminal (fcatToCat (args!!n) l)] symbolToCFSymbol (SymLit n l) = [NonTerminal (fcatToCat (args!!n) l)]
fsymbolToSymbol (FSymKS ts) = map Terminal ts symbolToCFSymbol (SymKS ts) = map Terminal ts
fixProfile :: Array FPointPos FSymbol -> Int -> Profile fixProfile :: Array DotPos Symbol -> Int -> Profile
fixProfile row i = [k | (k,j) <- nts, j == i] fixProfile row i = [k | (k,j) <- nts, j == i]
where where
nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt] nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt]
getPos (FSymCat j _) = [j] getPos (SymCat j _) = [j]
getPos (FSymLit j _) = [j] getPos (SymLit j _) = [j]
getPos _ = [] getPos _ = []
profilesToTerm :: [Profile] -> CFTerm profilesToTerm :: [Profile] -> CFTerm
profilesToTerm ps = CFObj f (zipWith profileToTerm argTypes ps) profilesToTerm ps = CFObj f (zipWith profileToTerm argTypes ps)
@@ -111,6 +111,6 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
profileToTerm :: CId -> Profile -> CFTerm profileToTerm :: CId -> Profile -> CFTerm
profileToTerm t [] = CFMeta t profileToTerm t [] = CFMeta t
profileToTerm _ xs = CFRes (last xs) -- FIXME: unify profileToTerm _ xs = CFRes (last xs) -- FIXME: unify
fruleToCFRule (c,FCoerce c') = ruleToCFRule (c,PCoerce c') =
[CFRule (fcatToCat c l) [NonTerminal (fcatToCat c' l)] (CFRes 0) [CFRule (fcatToCat c l) [NonTerminal (fcatToCat c' l)] (CFRes 0)
| l <- [0..catLinArity c-1]] | l <- [0..catLinArity c-1]]

10
src/compiler/GF/Speech/SRG.hs
View File

@@ -13,7 +13,6 @@ module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..), SRGItem, SRGSymbol
, ebnfPrinter , ebnfPrinter
, makeNonLeftRecursiveSRG , makeNonLeftRecursiveSRG
, makeNonRecursiveSRG , makeNonRecursiveSRG
, getSpeechLanguage
, isExternalCat , isExternalCat
, lookupFM_ , lookupFM_
) where ) where
@@ -29,9 +28,7 @@ import GF.Speech.FiniteState
import GF.Speech.RegExp import GF.Speech.RegExp
import GF.Speech.CFGToFA import GF.Speech.CFGToFA
import GF.Infra.Option import GF.Infra.Option
import PGF.CId import PGF
import PGF.Data
import PGF.Macros
import Data.List import Data.List
import Data.Maybe (fromMaybe, maybeToList) import Data.Maybe (fromMaybe, maybeToList)
@@ -116,7 +113,7 @@ mkSRG mkRules preprocess pgf cnc =
SRG { srgName = showCId cnc, SRG { srgName = showCId cnc,
srgStartCat = cfgStartCat cfg, srgStartCat = cfgStartCat cfg,
srgExternalCats = cfgExternalCats cfg, srgExternalCats = cfgExternalCats cfg,
srgLanguage = getSpeechLanguage pgf cnc, srgLanguage = languageCode pgf cnc,
srgRules = mkRules cfg } srgRules = mkRules cfg }
where cfg = renameCats (showCId cnc) $ preprocess $ pgfToCFG pgf cnc where cfg = renameCats (showCId cnc) $ preprocess $ pgfToCFG pgf cnc
@@ -131,9 +128,6 @@ renameCats prefix cfg = mapCFGCats renameCat cfg
names = Map.fromList [(c,pref++"_"++show i) | (pref,cs) <- catsByPrefix, (c,i) <- zip cs [1..]] names = Map.fromList [(c,pref++"_"++show i) | (pref,cs) <- catsByPrefix, (c,i) <- zip cs [1..]]
badCat c = error ("GF.Speech.SRG.renameCats: " ++ c ++ "\n" ++ prCFG cfg) badCat c = error ("GF.Speech.SRG.renameCats: " ++ c ++ "\n" ++ prCFG cfg)
getSpeechLanguage :: PGF -> CId -> Maybe String
getSpeechLanguage pgf cnc = fmap (replace '_' '-') $ lookConcrFlag pgf cnc (mkCId "language")
cfRulesToSRGRule :: [CFRule] -> SRGRule cfRulesToSRGRule :: [CFRule] -> SRGRule
cfRulesToSRGRule rs@(r:_) = SRGRule (lhsCat r) rhs cfRulesToSRGRule rs@(r:_) = SRGRule (lhsCat r) rhs
where where

5
src/compiler/GF/Speech/VoiceXML.hs
View File

@@ -12,8 +12,7 @@ import GF.Data.Utilities
import GF.Data.XML import GF.Data.XML
import GF.Infra.Ident import GF.Infra.Ident
import GF.Infra.Modules import GF.Infra.Modules
import GF.Speech.SRG (getSpeechLanguage) import PGF
import PGF.CId
import PGF.Data import PGF.Data
import PGF.Macros import PGF.Macros
@@ -30,7 +29,7 @@ grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) ""
where skel = pgfSkeleton pgf where skel = pgfSkeleton pgf
name = showCId cnc name = showCId cnc
qs = catQuestions pgf cnc (map fst skel) qs = catQuestions pgf cnc (map fst skel)
language = getSpeechLanguage pgf cnc language = languageCode pgf cnc
start = lookStartCat pgf start = lookStartCat pgf
-- --

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

@@ -103,7 +103,7 @@ import PGF.VisualizeTree
import PGF.Macros import PGF.Macros
import PGF.Expr (Tree) import PGF.Expr (Tree)
import PGF.Morphology import PGF.Morphology
import PGF.Data hiding (functions) import PGF.Data
import PGF.Binary import PGF.Binary
import qualified PGF.Parse as Parse import qualified PGF.Parse as Parse
@@ -252,10 +252,12 @@ generateAllDepth pgf cat = generate pgf cat
abstractName pgf = absname pgf abstractName pgf = absname pgf
languages pgf = cncnames pgf languages pgf = Map.keys (concretes pgf)
languageCode pgf lang = languageCode pgf lang =
fmap (replace '_' '-') $ lookConcrFlag pgf lang (mkCId "language") case lookConcrFlag pgf lang (mkCId "language") of
Just (LStr s) -> Just (replace '_' '-' s)
_ -> Nothing
categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))] categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))]

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

@@ -6,6 +6,7 @@ import PGF.Macros
import Data.Binary import Data.Binary
import Data.Binary.Put import Data.Binary.Put
import Data.Binary.Get import Data.Binary.Get
import Data.Array.IArray
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.IntMap as IntMap import qualified Data.IntMap as IntMap
@@ -16,23 +17,20 @@ pgfMajorVersion, pgfMinorVersion :: Word16
(pgfMajorVersion, pgfMinorVersion) = (1,0) (pgfMajorVersion, pgfMinorVersion) = (1,0)
instance Binary PGF where instance Binary PGF where
put pgf = putWord16be pgfMajorVersion >> put pgf = do putWord16be pgfMajorVersion
putWord16be pgfMinorVersion >> putWord16be pgfMinorVersion
put ( absname pgf, cncnames pgf put (gflags pgf)
, gflags pgf put (absname pgf, abstract pgf)
, abstract pgf, concretes pgf put (concretes pgf)
)
get = do v1 <- getWord16be get = do v1 <- getWord16be
v2 <- getWord16be v2 <- getWord16be
absname <- get
cncnames <- get
gflags <- get gflags <- get
abstract <- get (absname,abstract) <- get
concretes <- get concretes <- get
return $ updateProductionIndices $ return $ updateProductionIndices $
(PGF{ absname=absname, cncnames=cncnames (PGF{ gflags=gflags
, gflags=gflags , absname=absname, abstract=abstract
, abstract=abstract, concretes=concretes , concretes=concretes
}) })
instance Binary CId where instance Binary CId where
@@ -44,35 +42,35 @@ instance Binary Abstr where
get = do aflags <- get get = do aflags <- get
funs <- get funs <- get
cats <- get cats <- get
let catfuns = Map.mapWithKey (\cat _ -> [f | (f, (DTyp _ c _,_,_)) <- Map.toList funs, c==cat]) cats
return (Abstr{ aflags=aflags return (Abstr{ aflags=aflags
, funs=funs, cats=cats , funs=funs, cats=cats
, catfuns=catfuns , catfuns=Map.empty
}) })
instance Binary Concr where instance Binary Concr where
put cnc = put ( cflags cnc, printnames cnc put cnc = do put (cflags cnc)
, functions cnc, sequences cnc put (printnames cnc)
, productions cnc putArray2 (sequences cnc)
, totalCats cnc, startCats cnc putArray (cncfuns cnc)
) put (productions cnc)
put (cnccats cnc)
put (totalCats cnc)
get = do cflags <- get get = do cflags <- get
printnames <- get printnames <- get
functions <- get sequences <- getArray2
sequences <- get cncfuns <- getArray
productions <- get productions <- get
cnccats <- get
totalCats <- get totalCats <- get
startCats <- get
return (Concr{ cflags=cflags, printnames=printnames return (Concr{ cflags=cflags, printnames=printnames
, functions=functions,sequences=sequences , sequences=sequences, cncfuns=cncfuns, productions=productions
, productions = productions
, pproductions = IntMap.empty , pproductions = IntMap.empty
, lproductions = Map.empty , lproductions = Map.empty
, totalCats=totalCats,startCats=startCats , cnccats=cnccats, totalCats=totalCats
}) })
instance Binary Alternative where instance Binary Alternative where
put (Alt v x) = put v >> put x put (Alt v x) = put (v,x)
get = liftM2 Alt get get get = liftM2 Alt get get
instance Binary Term where instance Binary Term where
@@ -106,41 +104,37 @@ instance Binary Term where
instance Binary Expr where instance Binary Expr where
put (EAbs b x exp) = putWord8 0 >> put (b,x,exp) put (EAbs b x exp) = putWord8 0 >> put (b,x,exp)
put (EApp e1 e2) = putWord8 1 >> put (e1,e2) put (EApp e1 e2) = putWord8 1 >> put (e1,e2)
put (ELit (LStr s)) = putWord8 2 >> put s put (ELit l) = putWord8 2 >> put l
put (ELit (LFlt d)) = putWord8 3 >> put d put (EMeta i) = putWord8 3 >> put i
put (ELit (LInt i)) = putWord8 4 >> put i put (EFun f) = putWord8 4 >> put f
put (EMeta i) = putWord8 5 >> put i put (EVar i) = putWord8 5 >> put i
put (EFun f) = putWord8 6 >> put f put (ETyped e ty) = putWord8 6 >> put (e,ty)
put (EVar i) = putWord8 7 >> put i put (EImplArg e) = putWord8 7 >> put e
put (ETyped e ty) = putWord8 8 >> put (e,ty)
get = do tag <- getWord8 get = do tag <- getWord8
case tag of case tag of
0 -> liftM3 EAbs get get get 0 -> liftM3 EAbs get get get
1 -> liftM2 EApp get get 1 -> liftM2 EApp get get
2 -> liftM (ELit . LStr) get 2 -> liftM ELit get
3 -> liftM (ELit . LFlt) get 3 -> liftM EMeta get
4 -> liftM (ELit . LInt) get 4 -> liftM EFun get
5 -> liftM EMeta get 5 -> liftM EVar get
6 -> liftM EFun get 6 -> liftM2 ETyped get get
7 -> liftM EVar get 7 -> liftM EImplArg get
8 -> liftM2 ETyped get get
_ -> decodingError _ -> decodingError
instance Binary Patt where instance Binary Patt where
put (PApp f ps) = putWord8 0 >> put (f,ps) put (PApp f ps) = putWord8 0 >> put (f,ps)
put (PVar x) = putWord8 1 >> put x put (PVar x) = putWord8 1 >> put x
put PWild = putWord8 2 put PWild = putWord8 2
put (PLit (LStr s)) = putWord8 3 >> put s put (PLit l) = putWord8 3 >> put l
put (PLit (LFlt d)) = putWord8 4 >> put d put (PImplArg p) = putWord8 4 >> put p
put (PLit (LInt i)) = putWord8 5 >> put i
get = do tag <- getWord8 get = do tag <- getWord8
case tag of case tag of
0 -> liftM2 PApp get get 0 -> liftM2 PApp get get
1 -> liftM PVar get 1 -> liftM PVar get
2 -> return PWild 2 -> return PWild
3 -> liftM (PLit . LStr) get 3 -> liftM PLit get
4 -> liftM (PLit . LFlt) get 4 -> liftM PImplArg get
5 -> liftM (PLit . LInt) get
_ -> decodingError _ -> decodingError
instance Binary Equation where instance Binary Equation where
@@ -160,30 +154,65 @@ instance Binary BindType where
1 -> return Implicit 1 -> return Implicit
_ -> decodingError _ -> decodingError
instance Binary FFun where instance Binary CncFun where
put (FFun fun lins) = put (fun,lins) put (CncFun fun lins) = put fun >> putArray lins
get = liftM2 FFun get get get = liftM2 CncFun get getArray
instance Binary FSymbol where instance Binary CncCat where
put (FSymCat n l) = putWord8 0 >> put (n,l) put (CncCat s e labels) = do put (s,e)
put (FSymLit n l) = putWord8 1 >> put (n,l) putArray labels
put (FSymKS ts) = putWord8 2 >> put ts get = liftM3 CncCat get get getArray
put (FSymKP d vs) = putWord8 3 >> put (d,vs)
instance Binary Symbol where
put (SymCat n l) = putWord8 0 >> put (n,l)
put (SymLit n l) = putWord8 1 >> put (n,l)
put (SymKS ts) = putWord8 2 >> put ts
put (SymKP d vs) = putWord8 3 >> put (d,vs)
get = do tag <- getWord8 get = do tag <- getWord8
case tag of case tag of
0 -> liftM2 FSymCat get get 0 -> liftM2 SymCat get get
1 -> liftM2 FSymLit get get 1 -> liftM2 SymLit get get
2 -> liftM FSymKS get 2 -> liftM SymKS get
3 -> liftM2 (\d vs -> FSymKP d vs) get get 3 -> liftM2 (\d vs -> SymKP d vs) get get
_ -> decodingError _ -> decodingError
instance Binary Production where instance Binary Production where
put (FApply ruleid args) = putWord8 0 >> put (ruleid,args) put (PApply ruleid args) = putWord8 0 >> put (ruleid,args)
put (FCoerce fcat) = putWord8 1 >> put fcat put (PCoerce fcat) = putWord8 1 >> put fcat
get = do tag <- getWord8 get = do tag <- getWord8
case tag of case tag of
0 -> liftM2 FApply get get 0 -> liftM2 PApply get get
1 -> liftM FCoerce get 1 -> liftM PCoerce get
_ -> decodingError _ -> decodingError
instance Binary Literal where
put (LStr s) = putWord8 0 >> put s
put (LInt i) = putWord8 1 >> put i
put (LFlt d) = putWord8 2 >> put d
get = do tag <- getWord8
case tag of
0 -> liftM LStr get
1 -> liftM LFlt get
2 -> liftM LInt get
_ -> decodingError
putArray :: (Binary e, IArray a e) => a Int e -> Put
putArray a = do put (rangeSize $ bounds a) -- write the length
mapM_ put (elems a) -- now the elems.
getArray :: (Binary e, IArray a e) => Get (a Int e)
getArray = do n <- get -- read the length
xs <- replicateM n get -- now the elems.
return (listArray (0,n-1) xs)
putArray2 :: (Binary e, IArray a1 (a2 Int e), IArray a2 e) => a1 Int (a2 Int e) -> Put
putArray2 a = do put (rangeSize $ bounds a) -- write the length
mapM_ putArray (elems a) -- now the elems.
getArray2 :: (Binary e, IArray a1 (a2 Int e), IArray a2 e) => Get (a1 Int (a2 Int e))
getArray2 = do n <- get -- read the length
xs <- replicateM n getArray -- now the elems.
return (listArray (0,n-1) xs)
decodingError = fail "This PGF file was compiled with different version of GF" decodingError = fail "This PGF file was compiled with different version of GF"

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

@@ -17,48 +17,48 @@ import Data.List
-- | An abstract data type representing multilingual grammar -- | An abstract data type representing multilingual grammar
-- in Portable Grammar Format. -- in Portable Grammar Format.
data PGF = PGF { data PGF = PGF {
gflags :: Map.Map CId Literal, -- value of a global flag
absname :: CId , absname :: CId ,
cncnames :: [CId] ,
gflags :: Map.Map CId String, -- value of a global flag
abstract :: Abstr , abstract :: Abstr ,
concretes :: Map.Map CId Concr concretes :: Map.Map CId Concr
} }
data Abstr = Abstr { data Abstr = Abstr {
aflags :: Map.Map CId String, -- value of a flag aflags :: Map.Map CId Literal, -- value of a flag
funs :: Map.Map CId (Type,Int,[Equation]), -- type, arrity and definition of function funs :: Map.Map CId (Type,Int,[Equation]), -- type, arrity and definition of function
cats :: Map.Map CId [Hypo], -- context of a cat cats :: Map.Map CId [Hypo], -- context of a cat
catfuns :: Map.Map CId [CId] -- funs to a cat (redundant, for fast lookup) catfuns :: Map.Map CId [CId] -- funs to a cat (redundant, for fast lookup)
} }
data Concr = Concr { data Concr = Concr {
cflags :: Map.Map CId String, -- value of a flag cflags :: Map.Map CId Literal, -- value of a flag
printnames :: Map.Map CId String, -- printname of a cat or a fun printnames :: Map.Map CId String, -- printname of a cat or a fun
functions :: Array FunId FFun, cncfuns :: Array FunId CncFun,
sequences :: Array SeqId FSeq, sequences :: Array SeqId Sequence,
productions :: IntMap.IntMap (Set.Set Production), -- the original productions loaded from the PGF file productions :: IntMap.IntMap (Set.Set Production), -- the original productions loaded from the PGF file
pproductions :: IntMap.IntMap (Set.Set Production), -- productions needed for parsing pproductions :: IntMap.IntMap (Set.Set Production), -- productions needed for parsing
lproductions :: Map.Map CId (IntMap.IntMap (Set.Set Production)), -- productions needed for linearization 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 cnccats :: Map.Map CId CncCat,
totalCats :: {-# UNPACK #-} !FCat totalCats :: {-# UNPACK #-} !FId
} }
type FCat = Int type FId = Int
type FIndex = Int type LIndex = Int
type FPointPos = Int type DotPos = Int
data FSymbol data Symbol
= FSymCat {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
| FSymLit {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
| FSymKS [String] | SymKS [String]
| FSymKP [String] [Alternative] | SymKP [String] [Alternative]
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
data Production data Production
= FApply {-# UNPACK #-} !FunId [FCat] = PApply {-# UNPACK #-} !FunId [FId]
| FCoerce {-# UNPACK #-} !FCat | PCoerce {-# UNPACK #-} !FId
| FConst Expr [String] | PConst Expr [String]
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
data FFun = FFun CId {-# UNPACK #-} !(UArray FIndex SeqId) deriving (Eq,Ord,Show) data CncCat = CncCat {-# UNPACK #-} !FId {-# UNPACK #-} !FId {-# UNPACK #-} !(Array LIndex String)
type FSeq = Array FPointPos FSymbol data CncFun = CncFun CId {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord,Show)
type Sequence = Array DotPos Symbol
type FunId = Int type FunId = Int
type SeqId = Int type SeqId = Int
@@ -91,16 +91,14 @@ unionPGF :: PGF -> PGF -> PGF
unionPGF one two = case absname one of unionPGF one two = case absname one of
n | n == wildCId -> two -- extending empty grammar n | n == wildCId -> two -- extending empty grammar
| n == absname two -> one { -- extending grammar with same abstract | n == absname two -> one { -- extending grammar with same abstract
concretes = Map.union (concretes two) (concretes one), concretes = Map.union (concretes two) (concretes one)
cncnames = union (cncnames one) (cncnames two)
} }
_ -> one -- abstracts don't match ---- print error msg _ -> one -- abstracts don't match ---- print error msg
emptyPGF :: PGF emptyPGF :: PGF
emptyPGF = PGF { emptyPGF = PGF {
absname = wildCId,
cncnames = [] ,
gflags = Map.empty, gflags = Map.empty,
absname = wildCId,
abstract = error "empty grammar, no abstract", abstract = error "empty grammar, no abstract",
concretes = Map.empty concretes = Map.empty
} }
@@ -126,5 +124,5 @@ fcatInt = (-2)
fcatFloat = (-3) fcatFloat = (-3)
fcatVar = (-4) fcatVar = (-4)
isLiteralFCat :: FCat -> Bool isLiteralFCat :: FId -> Bool
isLiteralFCat = (`elem` [fcatString, fcatInt, fcatFloat, fcatVar]) isLiteralFCat = (`elem` [fcatString, fcatInt, fcatFloat, fcatVar])

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

@@ -31,7 +31,7 @@ import qualified Text.ParserCombinators.ReadP as RP
data Literal = data Literal =
LStr String -- ^ string constant LStr String -- ^ string constant
| LInt Integer -- ^ integer constant | LInt Int -- ^ integer constant
| LFlt Double -- ^ floating point constant | LFlt Double -- ^ floating point constant
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
@@ -116,11 +116,11 @@ unStr (ELit (LStr s)) = Just s
unStr _ = Nothing unStr _ = Nothing
-- | Constructs an expression from integer literal -- | Constructs an expression from integer literal
mkInt :: Integer -> Expr mkInt :: Int -> Expr
mkInt i = ELit (LInt i) mkInt i = ELit (LInt i)
-- | Decomposes an expression into integer literal -- | Decomposes an expression into integer literal
unInt :: Expr -> Maybe Integer unInt :: Expr -> Maybe Int
unInt (ELit (LInt i)) = Just i unInt (ELit (LInt i)) = Just i
unInt _ = Nothing unInt _ = Nothing
@@ -236,7 +236,7 @@ ppBind Explicit x = ppCId x
ppBind Implicit x = PP.braces (ppCId x) ppBind Implicit x = PP.braces (ppCId x)
ppLit (LStr s) = PP.text (show s) ppLit (LStr s) = PP.text (show s)
ppLit (LInt n) = PP.integer n ppLit (LInt n) = PP.int n
ppLit (LFlt d) = PP.double d ppLit (LFlt d) = PP.double d
ppMeta :: MetaId -> PP.Doc ppMeta :: MetaId -> PP.Doc

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

@@ -12,7 +12,7 @@ import qualified Data.Set as Set
-- linearization and computation of concrete PGF Terms -- linearization and computation of concrete PGF Terms
type LinTable = Array FIndex [Tokn] type LinTable = Array LIndex [Tokn]
linearizes :: PGF -> CId -> Expr -> [String] linearizes :: PGF -> CId -> Expr -> [String]
linearizes pgf lang = map (unwords . untokn . (! 0)) . linTree pgf lang (\_ _ lint -> lint) linearizes pgf lang = map (unwords . untokn . (! 0)) . linTree pgf lang (\_ _ lint -> lint)
@@ -46,11 +46,11 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e
Just prods -> case lookupProds mb_fid prods of Just prods -> case lookupProds mb_fid prods of
Just set -> do prod <- Set.toList set Just set -> do prod <- Set.toList set
case prod of case prod of
FApply funid fids -> do guard (length fids == length es) PApply 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) args <- sequence (zipWith3 (\i fid e -> lin0 (sub i path) [] xs (Just fid) e) [0..] fids es)
let (FFun _ lins) = functions cnc ! funid let (CncFun _ lins) = cncfuns cnc ! funid
return (listArray (bounds lins) [computeSeq seqid args | seqid <- elems lins]) return (listArray (bounds lins) [computeSeq seqid args | seqid <- elems lins])
FCoerce fid -> apply path xs (Just fid) f es PCoerce fid -> apply path xs (Just fid) f es
Nothing -> mzero Nothing -> mzero
Nothing -> apply path xs mb_fid _V [ELit (LStr "?")] -- function without linearization Nothing -> apply path xs mb_fid _V [ELit (LStr "?")] -- function without linearization
where where
@@ -63,17 +63,17 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e
| f == _B || f == _V = path | f == _B || f == _V = path
| otherwise = i:path | otherwise = i:path
isApp (FApply _ _) = True isApp (PApply _ _) = True
isApp _ = False isApp _ = False
computeSeq seqid args = concatMap compute (elems seq) computeSeq seqid args = concatMap compute (elems seq)
where where
seq = sequences cnc ! seqid seq = sequences cnc ! seqid
compute (FSymCat d r) = (args !! d) ! r compute (SymCat d r) = (args !! d) ! r
compute (FSymLit d r) = (args !! d) ! r compute (SymLit d r) = (args !! d) ! r
compute (FSymKS ts) = map KS ts compute (SymKS ts) = map KS ts
compute (FSymKP ts alts) = [KP ts alts] compute (SymKP ts alts) = [KP ts alts]
untokn :: [Tokn] -> [String] untokn :: [Tokn] -> [String]
untokn ts = case ts of untokn ts = case ts of
@@ -92,9 +92,9 @@ tabularLinearizes pgf lang e = map (zip lbls . map (unwords . untokn) . elems) (
where where
lbls = case unApp e of lbls = case unApp e of
Just (f,_) -> let cat = valCat (lookType pgf f) Just (f,_) -> let cat = valCat (lookType pgf f)
in case Map.lookup cat (startCats (lookConcr pgf lang)) of in case Map.lookup cat (cnccats (lookConcr pgf lang)) of
Just (_,_,lbls) -> elems lbls Just (CncCat _ _ lbls) -> elems lbls
Nothing -> error "No labels" Nothing -> error "No labels"
Nothing -> error "Not function application" Nothing -> error "Not function application"

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

@@ -37,22 +37,22 @@ lookValCat :: PGF -> CId -> CId
lookValCat pgf = valCat . lookType pgf lookValCat pgf = valCat . lookType pgf
lookStartCat :: PGF -> CId lookStartCat :: PGF -> CId
lookStartCat pgf = mkCId $ fromMaybe "S" $ msum $ Data.List.map (Map.lookup (mkCId "startcat")) lookStartCat pgf = mkCId $
[gflags pgf, aflags (abstract pgf)] case msum $ Data.List.map (Map.lookup (mkCId "startcat")) [gflags pgf, aflags (abstract pgf)] of
Just (LStr s) -> s
_ -> "S"
lookGlobalFlag :: PGF -> CId -> String lookGlobalFlag :: PGF -> CId -> Maybe Literal
lookGlobalFlag pgf f = lookGlobalFlag pgf f = Map.lookup f (gflags pgf)
lookMap "?" f (gflags pgf)
lookAbsFlag :: PGF -> CId -> String lookAbsFlag :: PGF -> CId -> Maybe Literal
lookAbsFlag pgf f = lookAbsFlag pgf f = Map.lookup f (aflags (abstract pgf))
lookMap "?" f (aflags (abstract pgf))
lookConcr :: PGF -> CId -> Concr lookConcr :: PGF -> CId -> Concr
lookConcr pgf cnc = lookConcr pgf cnc =
lookMap (error $ "Missing concrete syntax: " ++ showCId cnc) cnc $ concretes pgf lookMap (error $ "Missing concrete syntax: " ++ showCId cnc) cnc $ concretes pgf
lookConcrFlag :: PGF -> CId -> CId -> Maybe String lookConcrFlag :: PGF -> CId -> CId -> Maybe Literal
lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang
functionsToCat :: PGF -> CId -> [(CId,Type)] functionsToCat :: PGF -> CId -> [(CId,Type)]
@@ -142,8 +142,13 @@ _B = mkCId "__gfB"
_V = mkCId "__gfV" _V = mkCId "__gfV"
updateProductionIndices :: PGF -> PGF updateProductionIndices :: PGF -> PGF
updateProductionIndices pgf = pgf{concretes = fmap updateConcrete (concretes pgf)} updateProductionIndices pgf = pgf{ abstract = updateAbstract (abstract pgf)
, concretes = fmap updateConcrete (concretes pgf)
}
where where
updateAbstract abs =
abs{catfuns = Map.mapWithKey (\cat _ -> [f | (f, (DTyp _ c _,_,_)) <- Map.toList (funs abs), c==cat]) (cats abs)}
updateConcrete cnc = updateConcrete cnc =
let prods0 = filterProductions (productions cnc) let prods0 = filterProductions (productions cnc)
p_prods = parseIndex cnc prods0 p_prods = parseIndex cnc prods0
@@ -162,8 +167,8 @@ updateProductionIndices pgf = pgf{concretes = fmap updateConcrete (concretes pgf
where where
set = Set.filter (filterRule prods) set0 set = Set.filter (filterRule prods) set0
filterRule prods (FApply funid args) = all (\fcat -> isLiteralFCat fcat || IntMap.member fcat prods) args filterRule prods (PApply funid args) = all (\fcat -> isLiteralFCat fcat || IntMap.member fcat prods) args
filterRule prods (FCoerce fcat) = isLiteralFCat fcat || IntMap.member fcat prods filterRule prods (PCoerce fcat) = isLiteralFCat fcat || IntMap.member fcat prods
filterRule prods _ = True filterRule prods _ = True
parseIndex pinfo = IntMap.mapMaybeWithKey filterProdSet parseIndex pinfo = IntMap.mapMaybeWithKey filterProdSet
@@ -175,12 +180,12 @@ updateProductionIndices pgf = pgf{concretes = fmap updateConcrete (concretes pgf
then Nothing then Nothing
else Just prods' else Just prods'
is_ho_prod (FApply _ [fid]) | fid == fcatVar = True is_ho_prod (PApply _ [fid]) | fid == fcatVar = True
is_ho_prod _ = False is_ho_prod _ = False
ho_fids :: IntSet.IntSet ho_fids :: IntSet.IntSet
ho_fids = IntSet.fromList [fid | cat <- ho_cats ho_fids = IntSet.fromList [fid | cat <- ho_cats
, fid <- maybe [] (\(s,e,_) -> [s..e]) (Map.lookup cat (startCats pinfo))] , fid <- maybe [] (\(CncCat s e _) -> [s..e]) (Map.lookup cat (cnccats pinfo))]
ho_cats :: [CId] ho_cats :: [CId]
ho_cats = sortNub [c | (ty,_,_) <- Map.elems (funs (abstract pgf)) ho_cats = sortNub [c | (ty,_,_) <- Map.elems (funs (abstract pgf))
@@ -194,7 +199,7 @@ updateProductionIndices pgf = pgf{concretes = fmap updateConcrete (concretes pgf
, prod <- Set.toList prods , prod <- Set.toList prods
, fun <- getFunctions prod] , fun <- getFunctions prod]
where where
getFunctions (FApply funid args) = let FFun fun _ = functions pinfo Array.! funid in [fun] getFunctions (PApply funid args) = let CncFun fun _ = cncfuns pinfo Array.! funid in [fun]
getFunctions (FCoerce fid) = case IntMap.lookup fid productions of getFunctions (PCoerce fid) = case IntMap.lookup fid productions of
Nothing -> [] Nothing -> []
Just prods -> [fun | prod <- Set.toList prods, fun <- getFunctions prod] Just prods -> [fun | prod <- Set.toList prods, fun <- getFunctions prod]

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

@@ -25,17 +25,17 @@ buildMorpho pgf lang = Morpho $
Nothing -> Map.empty Nothing -> Map.empty
collectWords pinfo = Map.fromListWith (++) collectWords pinfo = Map.fromListWith (++)
[(t, [(fun,lbls ! l)]) | (s,e,lbls) <- Map.elems (startCats pinfo) [(t, [(fun,lbls ! l)]) | (CncCat s e lbls) <- Map.elems (cnccats pinfo)
, fid <- [s..e] , fid <- [s..e]
, FApply funid _ <- maybe [] Set.toList (IntMap.lookup fid (pproductions pinfo)) , PApply funid _ <- maybe [] Set.toList (IntMap.lookup fid (pproductions pinfo))
, let FFun fun lins = functions pinfo ! funid , let CncFun fun lins = cncfuns pinfo ! funid
, (l,seqid) <- assocs lins , (l,seqid) <- assocs lins
, sym <- elems (sequences pinfo ! seqid) , sym <- elems (sequences pinfo ! seqid)
, t <- sym2tokns sym] , t <- sym2tokns sym]
where where
sym2tokns (FSymKS ts) = ts sym2tokns (SymKS ts) = ts
sym2tokns (FSymKP ts alts) = ts ++ [t | Alt ts ps <- alts, t <- ts] sym2tokns (SymKP ts alts) = ts ++ [t | Alt ts ps <- alts, t <- ts]
sym2tokns _ = [] sym2tokns _ = []
lookupMorpho :: Morpho -> String -> [(Lemma,Analysis)] lookupMorpho :: Morpho -> String -> [(Lemma,Analysis)]
lookupMorpho (Morpho mo) s = maybe [] id $ Map.lookup s mo lookupMorpho (Morpho mo) s = maybe [] id $ Map.lookup s mo

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

@@ -56,14 +56,14 @@ parseWithRecovery pgf lang typ open_typs toks = accept (initState pgf lang typ)
-- startup category. -- startup category.
initState :: PGF -> Language -> Type -> ParseState initState :: PGF -> Language -> Type -> ParseState
initState pgf lang (DTyp _ start _) = initState pgf lang (DTyp _ start _) =
let items = case Map.lookup start (startCats cnc) of let items = case Map.lookup start (cnccats cnc) of
Just (s,e,labels) -> do cat <- range (s,e) Just (CncCat s e labels) -> do cat <- range (s,e)
(funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args) (funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args)
[] cat (pproductions cnc) [] cat (pproductions cnc)
let FFun fn lins = functions cnc ! funid let CncFun fn lins = cncfuns cnc ! funid
(lbl,seqid) <- assocs lins (lbl,seqid) <- assocs lins
return (Active 0 0 funid seqid args (AK cat lbl)) return (Active 0 0 funid seqid args (AK cat lbl))
Nothing -> mzero Nothing -> mzero
cnc = lookConcr pgf lang cnc = lookConcr pgf lang
@@ -82,7 +82,7 @@ nextState (PState pgf cnc chart items) t =
let (mb_agenda,map_items) = TMap.decompose items let (mb_agenda,map_items) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda agenda = maybe [] Set.toList mb_agenda
acc = fromMaybe TMap.empty (Map.lookup t map_items) acc = fromMaybe TMap.empty (Map.lookup t map_items)
(acc1,chart1) = process (Just t) add (sequences cnc) (functions cnc) agenda acc chart (acc1,chart1) = process (Just t) add (sequences cnc) (cncfuns cnc) agenda acc chart
chart2 = chart1{ active =emptyAC chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1 , actives=active chart1 : actives chart1
, passive=emptyPC , passive=emptyPC
@@ -105,7 +105,7 @@ getCompletions (PState pgf cnc chart items) w =
let (mb_agenda,map_items) = TMap.decompose items let (mb_agenda,map_items) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda agenda = maybe [] Set.toList mb_agenda
acc = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items acc = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items
(acc',chart1) = process Nothing add (sequences cnc) (functions cnc) agenda acc chart (acc',chart1) = process Nothing add (sequences cnc) (cncfuns cnc) agenda acc chart
chart2 = chart1{ active =emptyAC chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1 , actives=active chart1 : actives chart1
, passive=emptyPC , passive=emptyPC
@@ -121,7 +121,7 @@ recoveryStates :: [Type] -> ErrorState -> (ParseState, Map.Map String ParseState
recoveryStates open_types (EState pgf cnc chart) = recoveryStates open_types (EState pgf cnc chart) =
let open_fcats = concatMap type2fcats open_types let open_fcats = concatMap type2fcats open_types
agenda = foldl (complete open_fcats) [] (actives chart) agenda = foldl (complete open_fcats) [] (actives chart)
(acc,chart1) = process Nothing add (sequences cnc) (functions cnc) agenda Map.empty chart (acc,chart1) = process Nothing add (sequences cnc) (cncfuns cnc) agenda Map.empty chart
chart2 = chart1{ active =emptyAC chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1 , actives=active chart1 : actives chart1
, passive=emptyPC , passive=emptyPC
@@ -129,9 +129,9 @@ recoveryStates open_types (EState pgf cnc chart) =
} }
in (PState pgf cnc chart (TMap.singleton [] (Set.fromList agenda)), fmap (PState pgf cnc chart2) acc) in (PState pgf cnc chart (TMap.singleton [] (Set.fromList agenda)), fmap (PState pgf cnc chart2) acc)
where where
type2fcats (DTyp _ cat _) = case Map.lookup cat (startCats cnc) of type2fcats (DTyp _ cat _) = case Map.lookup cat (cnccats cnc) of
Just (s,e,labels) -> range (s,e) Just (CncCat s e labels) -> range (s,e)
Nothing -> [] Nothing -> []
complete open_fcats items ac = complete open_fcats items ac =
foldl (Set.fold (\(Active j' ppos funid seqid args keyc) -> foldl (Set.fold (\(Active j' ppos funid seqid args keyc) ->
@@ -151,23 +151,23 @@ extractTrees (PState pgf cnc chart items) ty@(DTyp _ start _) =
where where
(mb_agenda,acc) = TMap.decompose items (mb_agenda,acc) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda agenda = maybe [] Set.toList mb_agenda
(_,st) = process Nothing (\_ _ -> id) (sequences cnc) (functions cnc) agenda () chart (_,st) = process Nothing (\_ _ -> id) (sequences cnc) (cncfuns cnc) agenda () chart
exps = exps =
case Map.lookup start (startCats cnc) of case Map.lookup start (cnccats cnc) of
Just (s,e,lbls) -> do cat <- range (s,e) Just (CncCat s e lbls) -> do cat <- range (s,e)
lbl <- indices lbls lbl <- indices lbls
Just fid <- [lookupPC (PK cat lbl 0) (passive st)] Just fid <- [lookupPC (PK cat lbl 0) (passive st)]
(fvs,tree) <- go Set.empty 0 (0,fid) (fvs,tree) <- go Set.empty 0 (0,fid)
guard (Set.null fvs) guard (Set.null fvs)
return tree return tree
Nothing -> mzero Nothing -> mzero
go rec fcat' (d,fcat) go rec fcat' (d,fcat)
| fcat < totalCats cnc = 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 | Set.member fcat rec = mzero
| otherwise = foldForest (\funid args trees -> | otherwise = foldForest (\funid args trees ->
do let FFun fn lins = functions cnc ! funid do let CncFun fn lins = cncfuns cnc ! funid
args <- mapM (go (Set.insert fcat rec) fcat) (zip [0..] args) args <- mapM (go (Set.insert fcat rec) fcat) (zip [0..] args)
check_ho_fun fn args check_ho_fun fn args
`mplus` `mplus`
@@ -193,36 +193,36 @@ process mbt fn !seqs !funs [] ac
process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc chart process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc chart
| inRange (bounds lin) ppos = | inRange (bounds lin) ppos =
case unsafeAt lin ppos of case unsafeAt lin ppos of
FSymCat d r -> let !fid = args !! d SymCat d r -> let !fid = args !! d
key = AK fid r key = AK fid r
items2 = case lookupPC (mkPK key k) (passive chart) of items2 = case lookupPC (mkPK key k) (passive chart) of
Nothing -> items Nothing -> items
Just id -> (Active j (ppos+1) funid seqid (updateAt d id args) key0) : items Just id -> (Active j (ppos+1) funid seqid (updateAt d id args) key0) : items
items3 = foldForest (\funid args items -> Active k 0 funid (rhs funid r) args key : items) items3 = foldForest (\funid args items -> Active k 0 funid (rhs funid r) args key : items)
(\_ _ items -> items) (\_ _ items -> items)
items2 fid (forest chart) items2 fid (forest chart)
in case lookupAC key (active chart) of in case lookupAC key (active chart) of
Nothing -> process mbt fn seqs funs items3 acc chart{active=insertAC key (Set.singleton item) (active chart)} Nothing -> process mbt fn seqs funs items3 acc chart{active=insertAC key (Set.singleton item) (active chart)}
Just set | Set.member item set -> process mbt fn seqs funs items acc chart Just set | Set.member item set -> process mbt fn seqs funs items acc chart
| otherwise -> process mbt fn seqs funs items2 acc chart{active=insertAC key (Set.insert item set) (active chart)} | otherwise -> process mbt fn seqs funs items2 acc chart{active=insertAC key (Set.insert item set) (active chart)}
FSymKS toks -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc SymKS toks -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc
in process mbt fn seqs funs items acc' chart in process mbt fn seqs funs items acc' chart
FSymKP strs vars SymKP strs vars
-> let !acc' = foldl (\acc toks -> fn toks (Active j (ppos+1) funid seqid args key0) acc) acc -> let !acc' = foldl (\acc toks -> fn toks (Active j (ppos+1) funid seqid args key0) acc) acc
(strs:[strs' | Alt strs' _ <- vars]) (strs:[strs' | Alt strs' _ <- vars])
in process mbt fn seqs funs items acc' chart in process mbt fn seqs funs items acc' chart
FSymLit d r -> let !fid = args !! d SymLit d r -> let !fid = args !! d
in case [ts | FConst _ ts <- maybe [] Set.toList (IntMap.lookup fid (forest chart))] of in case [ts | PConst _ ts <- maybe [] Set.toList (IntMap.lookup fid (forest chart))] of
(toks:_) -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc (toks:_) -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc
in process mbt fn seqs funs items acc' chart in process mbt fn seqs funs items acc' chart
[] -> case litCatMatch fid mbt of [] -> case litCatMatch fid mbt of
Just (toks,lit) -> let fid' = nextId chart Just (toks,lit) -> let fid' = nextId chart
!acc' = fn toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc !acc' = fn toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc
in process mbt fn seqs funs items acc' chart{forest=IntMap.insert fid' (Set.singleton (FConst lit toks)) (forest chart) in process mbt fn seqs funs items acc' chart{forest=IntMap.insert fid' (Set.singleton (PConst lit toks)) (forest chart)
,nextId=nextId chart+1 ,nextId=nextId chart+1
} }
Nothing -> process mbt fn seqs funs items acc chart Nothing -> process mbt fn seqs funs items acc chart
| otherwise = | otherwise =
case lookupPC (mkPK key0 j) (passive chart) of case lookupPC (mkPK key0 j) (passive chart) of
Nothing -> let fid = nextId chart Nothing -> let fid = nextId chart
@@ -230,14 +230,14 @@ process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) ac
items2 = case lookupAC key0 ((active chart:actives chart) !! (k-j)) of items2 = case lookupAC key0 ((active chart:actives chart) !! (k-j)) of
Nothing -> items Nothing -> items
Just set -> Set.fold (\(Active j' ppos funid seqid args keyc) -> Just set -> Set.fold (\(Active j' ppos funid seqid args keyc) ->
let FSymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos let SymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos
in (:) (Active j' (ppos+1) funid seqid (updateAt d fid args) keyc)) items set in (:) (Active j' (ppos+1) funid seqid (updateAt d fid args) keyc)) items set
in process mbt fn seqs funs items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart) in process mbt fn seqs funs items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart)
,forest =IntMap.insert fid (Set.singleton (FApply funid args)) (forest chart) ,forest =IntMap.insert fid (Set.singleton (PApply funid args)) (forest chart)
,nextId =nextId chart+1 ,nextId =nextId chart+1
} }
Just id -> let items2 = [Active k 0 funid (rhs funid r) args (AK id r) | r <- labelsAC id (active chart)] ++ items Just id -> let items2 = [Active k 0 funid (rhs funid r) args (AK id r) | r <- labelsAC id (active chart)] ++ items
in process mbt fn seqs funs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (FApply funid args)) (forest chart)} in process mbt fn seqs funs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (PApply funid args)) (forest chart)}
where where
!lin = unsafeAt seqs seqid !lin = unsafeAt seqs seqid
!k = offset chart !k = offset chart
@@ -246,7 +246,7 @@ process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) ac
rhs funid lbl = unsafeAt lins lbl rhs funid lbl = unsafeAt lins lbl
where where
FFun _ lins = unsafeAt funs funid CncFun _ lins = unsafeAt funs funid
updateAt :: Int -> a -> [a] -> [a] updateAt :: Int -> a -> [a] -> [a]
@@ -268,15 +268,15 @@ litCatMatch _ _ = Nothing
data Active data Active
= Active {-# UNPACK #-} !Int = Active {-# UNPACK #-} !Int
{-# UNPACK #-} !FPointPos {-# UNPACK #-} !DotPos
{-# UNPACK #-} !FunId {-# UNPACK #-} !FunId
{-# UNPACK #-} !SeqId {-# UNPACK #-} !SeqId
[FCat] [FId]
{-# UNPACK #-} !ActiveKey {-# UNPACK #-} !ActiveKey
deriving (Eq,Show,Ord) deriving (Eq,Show,Ord)
data ActiveKey data ActiveKey
= AK {-# UNPACK #-} !FCat = AK {-# UNPACK #-} !FId
{-# UNPACK #-} !FIndex {-# UNPACK #-} !LIndex
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
type ActiveChart = IntMap.IntMap (IntMap.IntMap (Set.Set Active)) type ActiveChart = IntMap.IntMap (IntMap.IntMap (Set.Set Active))
@@ -286,13 +286,13 @@ emptyAC = IntMap.empty
lookupAC :: ActiveKey -> ActiveChart -> Maybe (Set.Set Active) lookupAC :: ActiveKey -> ActiveChart -> Maybe (Set.Set Active)
lookupAC (AK fcat l) chart = IntMap.lookup fcat chart >>= IntMap.lookup l lookupAC (AK fcat l) chart = IntMap.lookup fcat chart >>= IntMap.lookup l
lookupACByFCat :: FCat -> ActiveChart -> [Set.Set Active] lookupACByFCat :: FId -> ActiveChart -> [Set.Set Active]
lookupACByFCat fcat chart = lookupACByFCat fcat chart =
case IntMap.lookup fcat chart of case IntMap.lookup fcat chart of
Nothing -> [] Nothing -> []
Just map -> IntMap.elems map Just map -> IntMap.elems map
labelsAC :: FCat -> ActiveChart -> [FIndex] labelsAC :: FId -> ActiveChart -> [LIndex]
labelsAC fcat chart = labelsAC fcat chart =
case IntMap.lookup fcat chart of case IntMap.lookup fcat chart of
Nothing -> [] Nothing -> []
@@ -307,20 +307,20 @@ insertAC (AK fcat l) set chart = IntMap.insertWith IntMap.union fcat (IntMap.sin
---------------------------------------------------------------- ----------------------------------------------------------------
data PassiveKey data PassiveKey
= PK {-# UNPACK #-} !FCat = PK {-# UNPACK #-} !FId
{-# UNPACK #-} !FIndex {-# UNPACK #-} !LIndex
{-# UNPACK #-} !Int {-# UNPACK #-} !Int
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
type PassiveChart = Map.Map PassiveKey FCat type PassiveChart = Map.Map PassiveKey FId
emptyPC :: PassiveChart emptyPC :: PassiveChart
emptyPC = Map.empty emptyPC = Map.empty
lookupPC :: PassiveKey -> PassiveChart -> Maybe FCat lookupPC :: PassiveKey -> PassiveChart -> Maybe FId
lookupPC key chart = Map.lookup key chart lookupPC key chart = Map.lookup key chart
insertPC :: PassiveKey -> FCat -> PassiveChart -> PassiveChart insertPC :: PassiveKey -> FId -> PassiveChart -> PassiveChart
insertPC key fcat chart = Map.insert key fcat chart insertPC key fcat chart = Map.insert key fcat chart
@@ -328,15 +328,15 @@ insertPC key fcat chart = Map.insert key fcat chart
-- Forest -- Forest
---------------------------------------------------------------- ----------------------------------------------------------------
foldForest :: (FunId -> [FCat] -> b -> b) -> (Expr -> [String] -> b -> b) -> b -> FCat -> IntMap.IntMap (Set.Set Production) -> b foldForest :: (FunId -> [FId] -> b -> b) -> (Expr -> [String] -> b -> b) -> b -> FId -> IntMap.IntMap (Set.Set Production) -> b
foldForest f g b fcat forest = foldForest f g b fcat forest =
case IntMap.lookup fcat forest of case IntMap.lookup fcat forest of
Nothing -> b Nothing -> b
Just set -> Set.fold foldProd b set Just set -> Set.fold foldProd b set
where where
foldProd (FCoerce fcat) b = foldForest f g b fcat forest foldProd (PCoerce fcat) b = foldForest f g b fcat forest
foldProd (FApply funid args) b = f funid args b foldProd (PApply funid args) b = f funid args b
foldProd (FConst const toks) b = g const toks b foldProd (PConst const toks) b = g const toks b
---------------------------------------------------------------- ----------------------------------------------------------------
@@ -353,7 +353,7 @@ data Chart
, actives :: [ActiveChart] , actives :: [ActiveChart]
, passive :: PassiveChart , passive :: PassiveChart
, forest :: IntMap.IntMap (Set.Set Production) , forest :: IntMap.IntMap (Set.Set Production)
, nextId :: {-# UNPACK #-} !FCat , nextId :: {-# UNPACK #-} !FId
, offset :: {-# UNPACK #-} !Int , offset :: {-# UNPACK #-} !Int
} }
deriving Show deriving Show

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

@@ -40,34 +40,34 @@ ppCnc name cnc =
nest 2 (text "productions" $$ nest 2 (text "productions" $$
nest 2 (vcat [ppProduction (fcat,prod) | (fcat,set) <- IntMap.toList (productions cnc), prod <- Set.toList set]) $$ nest 2 (vcat [ppProduction (fcat,prod) | (fcat,set) <- IntMap.toList (productions cnc), prod <- Set.toList set]) $$
text "functions" $$ text "functions" $$
nest 2 (vcat (map ppFFun (assocs (functions cnc)))) $$ nest 2 (vcat (map ppCncFun (assocs (cncfuns cnc)))) $$
text "sequences" $$ text "sequences" $$
nest 2 (vcat (map ppSeq (assocs (sequences cnc)))) $$ nest 2 (vcat (map ppSeq (assocs (sequences cnc)))) $$
text "startcats" $$ text "categories" $$
nest 2 (vcat (map ppStartCat (Map.toList (startCats cnc))))) $$ nest 2 (vcat (map ppCncCat (Map.toList (cnccats cnc))))) $$
char '}' char '}'
ppProduction (fcat,FApply funid args) = ppProduction (fcat,PApply funid args) =
ppFCat fcat <+> text "->" <+> ppFunId funid <> brackets (hcat (punctuate comma (map ppFCat args))) ppFCat fcat <+> text "->" <+> ppFunId funid <> brackets (hcat (punctuate comma (map ppFCat args)))
ppProduction (fcat,FCoerce arg) = ppProduction (fcat,PCoerce arg) =
ppFCat fcat <+> text "->" <+> char '_' <> brackets (ppFCat arg) ppFCat fcat <+> text "->" <+> char '_' <> brackets (ppFCat arg)
ppProduction (fcat,FConst _ ss) = ppProduction (fcat,PConst _ ss) =
ppFCat fcat <+> text "->" <+> ppStrs ss ppFCat fcat <+> text "->" <+> ppStrs ss
ppFFun (funid,FFun fun arr) = ppCncFun (funid,CncFun fun arr) =
ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun) ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun)
ppSeq (seqid,seq) = ppSeq (seqid,seq) =
ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol (elems seq)) ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol (elems seq))
ppStartCat (id,(start,end,labels)) = ppCncCat (id,(CncCat start end labels)) =
ppCId id <+> text ":=" <+> (text "range " <+> brackets (ppFCat start <+> text ".." <+> ppFCat end) $$ ppCId id <+> text ":=" <+> (text "range " <+> brackets (ppFCat start <+> text ".." <+> ppFCat end) $$
text "labels" <+> brackets (vcat (map (text . show) (elems labels)))) text "labels" <+> brackets (vcat (map (text . show) (elems labels))))
ppSymbol (FSymCat d r) = char '<' <> int d <> comma <> int r <> char '>' ppSymbol (SymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
ppSymbol (FSymLit d r) = char '<' <> int d <> comma <> int r <> char '>' ppSymbol (SymLit d r) = char '<' <> int d <> comma <> int r <> char '>'
ppSymbol (FSymKS ts) = ppStrs ts ppSymbol (SymKS ts) = ppStrs ts
ppSymbol (FSymKP ts alts) = text "pre" <+> braces (hsep (punctuate semi (ppStrs ts : map ppAlt alts))) ppSymbol (SymKP 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) ppAlt (Alt ts ps) = ppStrs ts <+> char '/' <+> hsep (map (doubleQuotes . text) ps)

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

@@ -238,7 +238,7 @@ mtag = tag . ('n':) . uncommas
graphvizAlignment :: PGF -> Expr -> String graphvizAlignment :: PGF -> Expr -> String
graphvizAlignment pgf = prGraph True . lin2graph . linsMark where graphvizAlignment pgf = prGraph True . lin2graph . linsMark where
linsMark t = [concat (take 1 (markLinearizes pgf la t)) | la <- cncnames pgf] linsMark t = [concat (take 1 (markLinearizes pgf la t)) | la <- Map.keys (concretes pgf)]
lin2graph :: [String] -> [String] lin2graph :: [String] -> [String]
lin2graph ss = trace (show ss) $ prelude ++ nodes ++ links lin2graph ss = trace (show ss) $ prelude ++ nodes ++ links