mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
cleanup the code of the PGF interpreter and polish the binary serialization to match the preliminary specification
This commit is contained in:
krasimir
@@ -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.
|
||||
-- THIS DOES NOT WORK UNFORTUNATELY - can't use the grammar flag properly
|
||||
unlexx opts lang = {- trace (unwords optsC) $ -} stringOps Nothing optsC where ----
|
||||
optsC = case lookFlag pgf lang "coding" of
|
||||
Just "utf8" -> filter (/="to_utf8") $ map prOpt opts
|
||||
Just other | isOpt "to_utf8" opts ->
|
||||
optsC = case lookConcrFlag pgf (mkCId lang) (mkCId "coding") of
|
||||
Just (LStr "utf8") -> filter (/="to_utf8") $ map prOpt opts
|
||||
Just (LStr other) | isOpt "to_utf8" opts ->
|
||||
let cod = ("from_" ++ other)
|
||||
in cod : filter (/=cod) (map prOpt opts)
|
||||
_ -> map prOpt opts
|
||||
@@ -974,9 +974,6 @@ morphologyQuiz cod pgf ig typ = do
|
||||
infinity :: Int
|
||||
infinity = 256
|
||||
|
||||
lookFlag :: PGF -> String -> String -> Maybe String
|
||||
lookFlag pgf lang flag = lookConcrFlag pgf (mkCId lang) (mkCId flag)
|
||||
|
||||
prFullFormLexicon :: Morpho -> String
|
||||
prFullFormLexicon mo =
|
||||
unlines (map prMorphoAnalysis (fullFormLexicon mo))
|
||||
|
||||
@@ -1,7 +1,6 @@
|
||||
module GF.Compile.Export where
|
||||
|
||||
import PGF.CId
|
||||
import PGF.Data (PGF(..))
|
||||
import PGF
|
||||
import PGF.Printer
|
||||
import GF.Compile.PGFtoHaskell
|
||||
import GF.Compile.PGFtoProlog
|
||||
@@ -48,17 +47,17 @@ exportPGF opts fmt pgf =
|
||||
FmtRegExp -> single "rexp" regexpPrinter
|
||||
FmtFA -> single "dot" slfGraphvizPrinter
|
||||
where
|
||||
name = fromMaybe (showCId (absname pgf)) (flag optName opts)
|
||||
name = fromMaybe (showCId (abstractName pgf)) (flag optName opts)
|
||||
|
||||
multi :: String -> (PGF -> String) -> [(FilePath,String)]
|
||||
multi ext pr = [(name <.> ext, pr pgf)]
|
||||
|
||||
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.
|
||||
-- FIXME: there should be an option to change this.
|
||||
outputConcr :: PGF -> CId
|
||||
outputConcr pgf = case cncnames pgf of
|
||||
outputConcr pgf = case languages pgf of
|
||||
[] -> error "No concrete syntax."
|
||||
cnc:_ -> cnc
|
||||
|
||||
@@ -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
|
||||
(GrammarEnv last_id catSet seqSet funSet crcSet topdown1) -> IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) topdown1
|
||||
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
|
||||
ff :: FunId -> [[FCat]] -> GrammarEnv -> GrammarEnv
|
||||
ff :: FunId -> [[FId]] -> GrammarEnv -> GrammarEnv
|
||||
ff funid xs env
|
||||
| product (map Set.size ys) == count =
|
||||
case List.mapAccumL (\env c -> addFCoercion env (Set.toList c)) env ys of
|
||||
(env,args) -> addProduction env cat (FApply funid args)
|
||||
| otherwise = List.foldl (\env args -> addProduction env cat (FApply funid args)) env xs
|
||||
(env,args) -> addProduction env cat (PApply funid args)
|
||||
| otherwise = List.foldl (\env args -> addProduction env cat (PApply funid args)) env xs
|
||||
where
|
||||
count = length 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'
|
||||
(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
|
||||
|
||||
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
|
||||
return a = BM (\c s -> c a s)
|
||||
BM m >>= k = BM (\c s -> m (\a s -> unBM (k a) c s) s)
|
||||
where unBM (BM m) = m
|
||||
|
||||
instance MonadState ([ProtoFCat],[FSymbol]) BranchM where
|
||||
instance MonadState ([ProtoFCat],[Symbol]) BranchM where
|
||||
get = BM (\c s -> c s s)
|
||||
put s = BM (\c _ -> c () s)
|
||||
|
||||
instance Functor BranchM where
|
||||
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
|
||||
|
||||
variants :: [a] -> BranchM a
|
||||
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
|
||||
PFCat _ _ _ tcs = args !! nr
|
||||
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 FPath = [FIndex]
|
||||
data ProtoFCat = PFCat Int CId [FPath] [(FPath,[FIndex])]
|
||||
type FPath = [LIndex]
|
||||
data ProtoFCat = PFCat Int CId [FPath] [(FPath,[LIndex])]
|
||||
type Env = (ProtoFCat, [ProtoFCat])
|
||||
data ProtoFRule = PFRule CId {- function -}
|
||||
[(Int,CId)] {- argument types: context size and category -}
|
||||
@@ -210,7 +210,7 @@ data Branch a
|
||||
data Value a
|
||||
= Rec [Branch a]
|
||||
| Str a
|
||||
| Con FIndex
|
||||
| Con LIndex
|
||||
|
||||
|
||||
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 (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
|
||||
in (env1,Case nr path bs1)
|
||||
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
|
||||
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
|
||||
in (env1,Rec vs1)
|
||||
addSequences env (Str lin) = let (env1,seqid) = addFSeq env (optimizeLin lin)
|
||||
@@ -243,17 +243,17 @@ addSequences env (Con i) = (env,Con i)
|
||||
|
||||
|
||||
optimizeLin [] = []
|
||||
optimizeLin lin@(FSymKS _ : _) =
|
||||
optimizeLin lin@(SymKS _ : _) =
|
||||
let (ts,lin') = getRest lin
|
||||
in FSymKS ts : optimizeLin lin'
|
||||
in SymKS ts : optimizeLin lin'
|
||||
where
|
||||
getRest (FSymKS ts : lin) = let (ts1,lin') = getRest lin
|
||||
in (ts++ts1,lin')
|
||||
getRest lin = ([],lin)
|
||||
getRest (SymKS ts : lin) = let (ts1,lin') = getRest lin
|
||||
in (ts++ts1,lin')
|
||||
getRest lin = ([],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 (C nr) = convertCon ctype nr (reverse sel)
|
||||
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 (S ts) = do vs <- mapM (convertTerm cnc_defs sel ctype) ts
|
||||
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 (KP s v))=return (Str [FSymKP s v])
|
||||
convertTerm cnc_defs sel ctype (K (KS t)) = return (Str [SymKS [t]])
|
||||
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
|
||||
Just term -> convertTerm cnc_defs sel ctype term
|
||||
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]
|
||||
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
|
||||
mkRecord (zipWith (\lbl ctype -> convertArg ctype nr (lbl:path)) [0..] ctypes)
|
||||
convertArg (C max) nr path = do
|
||||
@@ -287,8 +287,8 @@ convertArg (S _) nr path = do
|
||||
(args,_) <- get
|
||||
let PFCat _ cat rcs tcs = args !! nr
|
||||
l = index path rcs 0
|
||||
sym | isLiteralCat cat = FSymLit nr l
|
||||
| otherwise = FSymCat nr l
|
||||
sym | isLiteralCat cat = SymLit nr l
|
||||
| otherwise = SymCat nr l
|
||||
return (Str [sym])
|
||||
where
|
||||
index lbl' (lbl:lbls) idx
|
||||
@@ -307,7 +307,7 @@ convertRec cnc_defs (index:sub_sel) ctype record =
|
||||
------------------------------------------------------------
|
||||
-- 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 (C nr) = return nr
|
||||
evalTerm cnc_defs path (R record) = case path of
|
||||
@@ -325,10 +325,10 @@ evalTerm cnc_defs path x = error ("evalTerm ("++show x++")")
|
||||
-- GrammarEnv
|
||||
|
||||
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 SeqSet = Map.Map FSeq SeqId
|
||||
type FunSet = Map.Map FFun FunId
|
||||
type CoerceSet= Map.Map [FCat] FCat
|
||||
type CatSet = IntMap.IntMap (Map.Map CId (FId,FId,[Int],Array LIndex String))
|
||||
type SeqSet = Map.Map Sequence SeqId
|
||||
type FunSet = Map.Map CncFun FunId
|
||||
type CoerceSet= Map.Map [FId] FId
|
||||
|
||||
emptyGrammarEnv cnc_defs lincats params =
|
||||
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_hoFun env (n,cat) =
|
||||
let linRec = [[FSymCat 0 i] | i <- case arg of {PFCat _ _ rcs _ -> [0..length rcs-1]}] ++
|
||||
[[FSymLit i 0] | i <- [1..n]]
|
||||
let linRec = [[SymCat 0 i] | i <- case arg of {PFCat _ _ rcs _ -> [0..length rcs-1]}] ++
|
||||
[[SymLit i 0] | i <- [1..n]]
|
||||
(env1,lins) = List.mapAccumL addFSeq env linRec
|
||||
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
|
||||
(zip (getFCats env2 arg) (getFCats env2 res))
|
||||
in env3
|
||||
@@ -405,11 +405,11 @@ expandHOAS abs_defs cnc_defs lincats lindefs env =
|
||||
Nothing -> error $ "No lincat for " ++ showCId cat
|
||||
Just ctype -> ctype
|
||||
|
||||
addProduction :: GrammarEnv -> FCat -> Production -> GrammarEnv
|
||||
addProduction :: GrammarEnv -> FId -> Production -> GrammarEnv
|
||||
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)
|
||||
|
||||
addFSeq :: GrammarEnv -> [FSymbol] -> (GrammarEnv,SeqId)
|
||||
addFSeq :: GrammarEnv -> [Symbol] -> (GrammarEnv,SeqId)
|
||||
addFSeq env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) lst =
|
||||
case Map.lookup seq seqSet of
|
||||
Just id -> (env,id)
|
||||
@@ -418,14 +418,14 @@ addFSeq env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) lst =
|
||||
where
|
||||
seq = mkArray lst
|
||||
|
||||
addFFun :: GrammarEnv -> FFun -> (GrammarEnv,FunId)
|
||||
addFFun env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) fun =
|
||||
addCncFun :: GrammarEnv -> CncFun -> (GrammarEnv,FunId)
|
||||
addCncFun env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) fun =
|
||||
case Map.lookup fun funSet of
|
||||
Just id -> (env,id)
|
||||
Nothing -> let !last_funid = Map.size funSet
|
||||
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 =
|
||||
case sub_fcats of
|
||||
[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
|
||||
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) =
|
||||
Concr { cflags = flags
|
||||
, printnames = printnames
|
||||
, functions = mkArray funSet
|
||||
, cncfuns = mkArray funSet
|
||||
, sequences = mkArray seqSet
|
||||
, productions = IntMap.union prodSet coercions
|
||||
, pproductions = IntMap.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
|
||||
}
|
||||
where
|
||||
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) =
|
||||
case IntMap.lookup n catSet >>= Map.lookup cat of
|
||||
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
|
||||
|
||||
restrictArg :: FIndex -> FPath -> FIndex -> BacktrackM Env ()
|
||||
restrictArg :: LIndex -> FPath -> LIndex -> BacktrackM Env ()
|
||||
restrictArg nr path index = do
|
||||
(head, args) <- get
|
||||
args' <- updateNthM (restrictProtoFCat path index) nr args
|
||||
put (head, args')
|
||||
|
||||
restrictHead :: FPath -> FIndex -> BacktrackM Env ()
|
||||
restrictHead :: FPath -> LIndex -> BacktrackM Env ()
|
||||
restrictHead path term
|
||||
= do (head, args) <- get
|
||||
head' <- restrictProtoFCat path term head
|
||||
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
|
||||
tcs <- addConstraint tcs
|
||||
return (PFCat n cat rcs tcs)
|
||||
|
||||
@@ -52,14 +52,13 @@ canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do
|
||||
then putStrLn (render (vcat (map (ppModule Qualified) (M.modules cgr))))
|
||||
else return ()
|
||||
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
|
||||
-- abstract
|
||||
an = (i2i a)
|
||||
cns = map (i2i . fst) cms
|
||||
abs = D.Abstr aflags funs cats catfuns
|
||||
abs = D.Abstr aflags funs cats 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 Nothing = []
|
||||
@@ -85,7 +84,7 @@ canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do
|
||||
return (lang, cnc)
|
||||
where
|
||||
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) $
|
||||
-- if moduleFlag optEncoding (moduleOptions (M.flags mo)) == UTF_8
|
||||
-- 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
|
||||
Just i -> foldl C.EApp (C.EVar i) 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)
|
||||
K s -> C.ELit (C.LStr s)
|
||||
Meta i -> C.EMeta i
|
||||
@@ -144,7 +143,7 @@ mkPatt scope p =
|
||||
in (scope',C.PApp (i2i c) ps')
|
||||
A.PV x -> (x:scope,C.PVar (i2i x))
|
||||
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.PString s -> ( scope,C.PLit (C.LStr s))
|
||||
|
||||
|
||||
@@ -39,21 +39,25 @@ absdef2js (f,(typ,_,_)) =
|
||||
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)])
|
||||
|
||||
lit2js (LStr s) = JS.EStr s
|
||||
lit2js (LInt n) = JS.EInt n
|
||||
lit2js (LFlt d) = JS.EDbl d
|
||||
|
||||
concrete2js :: (CId,Concr) -> JS.Property
|
||||
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.EArray $ (map ffun2js (Array.elems (functions cnc))),
|
||||
JS.EArray $ (map ffun2js (Array.elems (cncfuns 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)])
|
||||
where
|
||||
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)]]),
|
||||
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)]])]
|
||||
cats (c,(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)])
|
||||
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)])
|
||||
|
||||
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)])
|
||||
@@ -92,19 +96,19 @@ children :: JS.Ident
|
||||
children = JS.Ident "cs"
|
||||
|
||||
frule2js :: Production -> JS.Expr
|
||||
frule2js (FApply funid args) = new "Rule" [JS.EInt funid, JS.EArray (map JS.EInt args)]
|
||||
frule2js (FCoerce arg) = new "Coerce" [JS.EInt arg]
|
||||
frule2js (PApply funid args) = new "Rule" [JS.EInt funid, JS.EArray (map JS.EInt args)]
|
||||
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]
|
||||
|
||||
sym2js :: FSymbol -> JS.Expr
|
||||
sym2js (FSymCat n l) = new "Arg" [JS.EInt n, JS.EInt l]
|
||||
sym2js (FSymLit n l) = new "Lit" [JS.EInt n, JS.EInt l]
|
||||
sym2js (FSymKS 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 :: Symbol -> JS.Expr
|
||||
sym2js (SymCat n l) = new "Arg" [JS.EInt n, JS.EInt l]
|
||||
sym2js (SymLit n l) = new "Lit" [JS.EInt n, JS.EInt l]
|
||||
sym2js (SymKS ts) = new "KS" (map JS.EStr ts)
|
||||
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)]
|
||||
|
||||
|
||||
@@ -28,17 +28,15 @@ grammar2prolog_abs = {- encodeUTF8 . -} foldr (++++) [] . pgf2clauses_abs
|
||||
|
||||
|
||||
pgf2clauses :: PGF -> [String]
|
||||
pgf2clauses (PGF absname cncnames gflags abstract concretes) =
|
||||
pgf2clauses (PGF gflags absname abstract concretes) =
|
||||
[":- " ++ plFact "module" [plp absname, "[]"]] ++
|
||||
clauseHeader "%% concrete(?Module)"
|
||||
[plFact "concrete" [plp cncname] | cncname <- cncnames] ++
|
||||
clauseHeader "%% flag(?Flag, ?Value): global flags"
|
||||
(map (plpFact2 "flag") (Map.assocs gflags)) ++
|
||||
plAbstract (absname, abstract) ++
|
||||
concatMap plConcrete (Map.assocs concretes)
|
||||
|
||||
pgf2clauses_abs :: PGF -> [String]
|
||||
pgf2clauses_abs (PGF absname _cncnames gflags abstract _concretes) =
|
||||
pgf2clauses_abs (PGF gflags absname abstract _concretes) =
|
||||
[":- " ++ plFact "module" [plp absname, "[]"]] ++
|
||||
clauseHeader "%% flag(?Flag, ?Value): global flags"
|
||||
(map (plpFact2 "flag") (Map.assocs gflags)) ++
|
||||
|
||||
@@ -14,8 +14,7 @@ import GF.Speech.SRG
|
||||
import GF.Speech.RegExp
|
||||
import GF.Infra.Option
|
||||
import GF.Infra.Ident
|
||||
import PGF.CId
|
||||
import PGF.Data
|
||||
import PGF
|
||||
|
||||
import Data.Char (toUpper,toLower)
|
||||
import Data.List (partition)
|
||||
|
||||
@@ -10,7 +10,7 @@ import PGF.CId
|
||||
import PGF.Data as PGF
|
||||
import PGF.Macros
|
||||
import GF.Infra.Ident
|
||||
import GF.Speech.CFG
|
||||
import GF.Speech.CFG hiding (Symbol)
|
||||
|
||||
import Data.Array.IArray as Array
|
||||
import Data.List
|
||||
@@ -32,36 +32,36 @@ type Profile = [Int]
|
||||
pgfToCFG :: PGF
|
||||
-> CId -- ^ Concrete syntax name
|
||||
-> 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
|
||||
cnc = lookConcr pgf lang
|
||||
|
||||
rules :: [(FCat,Production)]
|
||||
rules :: [(FId,Production)]
|
||||
rules = [(fcat,prod) | (fcat,set) <- IntMap.toList (PGF.pproductions cnc)
|
||||
, prod <- Set.toList set]
|
||||
|
||||
fcatCats :: Map FCat Cat
|
||||
fcatCats :: Map FId Cat
|
||||
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..]]
|
||||
|
||||
fcatCat :: FCat -> Cat
|
||||
fcatCat :: FId -> Cat
|
||||
fcatCat c = Map.findWithDefault ("Unknown_" ++ show c) c fcatCats
|
||||
|
||||
fcatToCat :: FCat -> FIndex -> Cat
|
||||
fcatToCat :: FId -> LIndex -> Cat
|
||||
fcatToCat c l = fcatCat c ++ row
|
||||
where row = if catLinArity c == 1 then "" else "_" ++ show l
|
||||
|
||||
-- gets the number of fields in the lincat for the given category
|
||||
catLinArity :: FCat -> Int
|
||||
catLinArity c = maximum (1:[rangeSize (bounds rhs) | (FFun _ rhs, _) <- topdownRules c])
|
||||
catLinArity :: FId -> Int
|
||||
catLinArity c = maximum (1:[rangeSize (bounds rhs) | (CncFun _ rhs, _) <- topdownRules c])
|
||||
|
||||
topdownRules cat = f cat []
|
||||
where
|
||||
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 (FCoerce cat) rules = f cat rules
|
||||
g (PApply funid args) rules = (cncfuns cnc ! funid,args) : rules
|
||||
g (PCoerce cat) rules = f cat rules
|
||||
|
||||
|
||||
extCats :: Set Cat
|
||||
@@ -69,40 +69,40 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
|
||||
|
||||
startRules :: [CFRule]
|
||||
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),
|
||||
r <- [0..catLinArity fc-1]]
|
||||
|
||||
fruleToCFRule :: (FCat,Production) -> [CFRule]
|
||||
fruleToCFRule (c,FApply funid args) =
|
||||
ruleToCFRule :: (FId,Production) -> [CFRule]
|
||||
ruleToCFRule (c,PApply funid args) =
|
||||
[CFRule (fcatToCat c l) (mkRhs row) (profilesToTerm [fixProfile row n | n <- [0..length args-1]])
|
||||
| (l,seqid) <- Array.assocs rhs
|
||||
, let row = sequences cnc ! seqid
|
||||
, not (containsLiterals row)]
|
||||
where
|
||||
FFun f rhs = functions cnc ! funid
|
||||
CncFun f rhs = cncfuns cnc ! funid
|
||||
|
||||
mkRhs :: Array FPointPos FSymbol -> [CFSymbol]
|
||||
mkRhs = concatMap fsymbolToSymbol . Array.elems
|
||||
mkRhs :: Array DotPos Symbol -> [CFSymbol]
|
||||
mkRhs = concatMap symbolToCFSymbol . Array.elems
|
||||
|
||||
containsLiterals :: Array FPointPos FSymbol -> Bool
|
||||
containsLiterals row = any isLiteralFCat [args!!n | FSymCat n _ <- Array.elems row] ||
|
||||
not (null [n | FSymLit n _ <- Array.elems row]) -- only this is needed for PMCFG.
|
||||
-- The first line is for backward compat.
|
||||
containsLiterals :: Array DotPos Symbol -> Bool
|
||||
containsLiterals row = any isLiteralFCat [args!!n | SymCat n _ <- Array.elems row] ||
|
||||
not (null [n | SymLit n _ <- Array.elems row]) -- only this is needed for PMCFG.
|
||||
-- The first line is for backward compat.
|
||||
|
||||
fsymbolToSymbol :: FSymbol -> [CFSymbol]
|
||||
fsymbolToSymbol (FSymCat n l) = [NonTerminal (fcatToCat (args!!n) l)]
|
||||
fsymbolToSymbol (FSymLit n l) = [NonTerminal (fcatToCat (args!!n) l)]
|
||||
fsymbolToSymbol (FSymKS ts) = map Terminal ts
|
||||
symbolToCFSymbol :: Symbol -> [CFSymbol]
|
||||
symbolToCFSymbol (SymCat n l) = [NonTerminal (fcatToCat (args!!n) l)]
|
||||
symbolToCFSymbol (SymLit n l) = [NonTerminal (fcatToCat (args!!n) l)]
|
||||
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]
|
||||
where
|
||||
nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt]
|
||||
|
||||
getPos (FSymCat j _) = [j]
|
||||
getPos (FSymLit j _) = [j]
|
||||
getPos _ = []
|
||||
getPos (SymCat j _) = [j]
|
||||
getPos (SymLit j _) = [j]
|
||||
getPos _ = []
|
||||
|
||||
profilesToTerm :: [Profile] -> CFTerm
|
||||
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 t [] = CFMeta t
|
||||
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)
|
||||
| l <- [0..catLinArity c-1]]
|
||||
|
||||
@@ -13,7 +13,6 @@ module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..), SRGItem, SRGSymbol
|
||||
, ebnfPrinter
|
||||
, makeNonLeftRecursiveSRG
|
||||
, makeNonRecursiveSRG
|
||||
, getSpeechLanguage
|
||||
, isExternalCat
|
||||
, lookupFM_
|
||||
) where
|
||||
@@ -29,9 +28,7 @@ import GF.Speech.FiniteState
|
||||
import GF.Speech.RegExp
|
||||
import GF.Speech.CFGToFA
|
||||
import GF.Infra.Option
|
||||
import PGF.CId
|
||||
import PGF.Data
|
||||
import PGF.Macros
|
||||
import PGF
|
||||
|
||||
import Data.List
|
||||
import Data.Maybe (fromMaybe, maybeToList)
|
||||
@@ -116,7 +113,7 @@ mkSRG mkRules preprocess pgf cnc =
|
||||
SRG { srgName = showCId cnc,
|
||||
srgStartCat = cfgStartCat cfg,
|
||||
srgExternalCats = cfgExternalCats cfg,
|
||||
srgLanguage = getSpeechLanguage pgf cnc,
|
||||
srgLanguage = languageCode pgf cnc,
|
||||
srgRules = mkRules cfg }
|
||||
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..]]
|
||||
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 rs@(r:_) = SRGRule (lhsCat r) rhs
|
||||
where
|
||||
|
||||
@@ -12,8 +12,7 @@ import GF.Data.Utilities
|
||||
import GF.Data.XML
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Modules
|
||||
import GF.Speech.SRG (getSpeechLanguage)
|
||||
import PGF.CId
|
||||
import PGF
|
||||
import PGF.Data
|
||||
import PGF.Macros
|
||||
|
||||
@@ -30,7 +29,7 @@ grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) ""
|
||||
where skel = pgfSkeleton pgf
|
||||
name = showCId cnc
|
||||
qs = catQuestions pgf cnc (map fst skel)
|
||||
language = getSpeechLanguage pgf cnc
|
||||
language = languageCode pgf cnc
|
||||
start = lookStartCat pgf
|
||||
|
||||
--
|
||||
|
||||
@@ -103,7 +103,7 @@ import PGF.VisualizeTree
|
||||
import PGF.Macros
|
||||
import PGF.Expr (Tree)
|
||||
import PGF.Morphology
|
||||
import PGF.Data hiding (functions)
|
||||
import PGF.Data
|
||||
import PGF.Binary
|
||||
import qualified PGF.Parse as Parse
|
||||
|
||||
@@ -252,10 +252,12 @@ generateAllDepth pgf cat = generate pgf cat
|
||||
|
||||
abstractName pgf = absname pgf
|
||||
|
||||
languages pgf = cncnames pgf
|
||||
languages pgf = Map.keys (concretes pgf)
|
||||
|
||||
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))]
|
||||
|
||||
|
||||
@@ -6,6 +6,7 @@ import PGF.Macros
|
||||
import Data.Binary
|
||||
import Data.Binary.Put
|
||||
import Data.Binary.Get
|
||||
import Data.Array.IArray
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.IntMap as IntMap
|
||||
@@ -16,23 +17,20 @@ pgfMajorVersion, pgfMinorVersion :: Word16
|
||||
(pgfMajorVersion, pgfMinorVersion) = (1,0)
|
||||
|
||||
instance Binary PGF where
|
||||
put pgf = putWord16be pgfMajorVersion >>
|
||||
putWord16be pgfMinorVersion >>
|
||||
put ( absname pgf, cncnames pgf
|
||||
, gflags pgf
|
||||
, abstract pgf, concretes pgf
|
||||
)
|
||||
put pgf = do putWord16be pgfMajorVersion
|
||||
putWord16be pgfMinorVersion
|
||||
put (gflags pgf)
|
||||
put (absname pgf, abstract pgf)
|
||||
put (concretes pgf)
|
||||
get = do v1 <- getWord16be
|
||||
v2 <- getWord16be
|
||||
absname <- get
|
||||
cncnames <- get
|
||||
gflags <- get
|
||||
abstract <- get
|
||||
(absname,abstract) <- get
|
||||
concretes <- get
|
||||
return $ updateProductionIndices $
|
||||
(PGF{ absname=absname, cncnames=cncnames
|
||||
, gflags=gflags
|
||||
, abstract=abstract, concretes=concretes
|
||||
(PGF{ gflags=gflags
|
||||
, absname=absname, abstract=abstract
|
||||
, concretes=concretes
|
||||
})
|
||||
|
||||
instance Binary CId where
|
||||
@@ -44,35 +42,35 @@ instance Binary Abstr where
|
||||
get = do aflags <- get
|
||||
funs <- get
|
||||
cats <- get
|
||||
let catfuns = Map.mapWithKey (\cat _ -> [f | (f, (DTyp _ c _,_,_)) <- Map.toList funs, c==cat]) cats
|
||||
return (Abstr{ aflags=aflags
|
||||
, funs=funs, cats=cats
|
||||
, catfuns=catfuns
|
||||
, catfuns=Map.empty
|
||||
})
|
||||
|
||||
instance Binary Concr where
|
||||
put cnc = put ( cflags cnc, printnames cnc
|
||||
, functions cnc, sequences cnc
|
||||
, productions cnc
|
||||
, totalCats cnc, startCats cnc
|
||||
)
|
||||
put cnc = do put (cflags cnc)
|
||||
put (printnames cnc)
|
||||
putArray2 (sequences cnc)
|
||||
putArray (cncfuns cnc)
|
||||
put (productions cnc)
|
||||
put (cnccats cnc)
|
||||
put (totalCats cnc)
|
||||
get = do cflags <- get
|
||||
printnames <- get
|
||||
functions <- get
|
||||
sequences <- get
|
||||
sequences <- getArray2
|
||||
cncfuns <- getArray
|
||||
productions <- get
|
||||
cnccats <- get
|
||||
totalCats <- get
|
||||
startCats <- get
|
||||
return (Concr{ cflags=cflags, printnames=printnames
|
||||
, functions=functions,sequences=sequences
|
||||
, productions = productions
|
||||
, sequences=sequences, cncfuns=cncfuns, productions=productions
|
||||
, pproductions = IntMap.empty
|
||||
, lproductions = Map.empty
|
||||
, totalCats=totalCats,startCats=startCats
|
||||
, cnccats=cnccats, totalCats=totalCats
|
||||
})
|
||||
|
||||
instance Binary Alternative where
|
||||
put (Alt v x) = put v >> put x
|
||||
put (Alt v x) = put (v,x)
|
||||
get = liftM2 Alt get get
|
||||
|
||||
instance Binary Term where
|
||||
@@ -106,41 +104,37 @@ instance Binary Term where
|
||||
instance Binary Expr where
|
||||
put (EAbs b x exp) = putWord8 0 >> put (b,x,exp)
|
||||
put (EApp e1 e2) = putWord8 1 >> put (e1,e2)
|
||||
put (ELit (LStr s)) = putWord8 2 >> put s
|
||||
put (ELit (LFlt d)) = putWord8 3 >> put d
|
||||
put (ELit (LInt i)) = putWord8 4 >> put i
|
||||
put (EMeta i) = putWord8 5 >> put i
|
||||
put (EFun f) = putWord8 6 >> put f
|
||||
put (EVar i) = putWord8 7 >> put i
|
||||
put (ETyped e ty) = putWord8 8 >> put (e,ty)
|
||||
put (ELit l) = putWord8 2 >> put l
|
||||
put (EMeta i) = putWord8 3 >> put i
|
||||
put (EFun f) = putWord8 4 >> put f
|
||||
put (EVar i) = putWord8 5 >> put i
|
||||
put (ETyped e ty) = putWord8 6 >> put (e,ty)
|
||||
put (EImplArg e) = putWord8 7 >> put e
|
||||
get = do tag <- getWord8
|
||||
case tag of
|
||||
0 -> liftM3 EAbs get get get
|
||||
1 -> liftM2 EApp get get
|
||||
2 -> liftM (ELit . LStr) get
|
||||
3 -> liftM (ELit . LFlt) get
|
||||
4 -> liftM (ELit . LInt) get
|
||||
5 -> liftM EMeta get
|
||||
6 -> liftM EFun get
|
||||
7 -> liftM EVar get
|
||||
8 -> liftM2 ETyped get get
|
||||
2 -> liftM ELit get
|
||||
3 -> liftM EMeta get
|
||||
4 -> liftM EFun get
|
||||
5 -> liftM EVar get
|
||||
6 -> liftM2 ETyped get get
|
||||
7 -> liftM EImplArg get
|
||||
_ -> decodingError
|
||||
|
||||
instance Binary Patt where
|
||||
put (PApp f ps) = putWord8 0 >> put (f,ps)
|
||||
put (PVar x) = putWord8 1 >> put x
|
||||
put PWild = putWord8 2
|
||||
put (PLit (LStr s)) = putWord8 3 >> put s
|
||||
put (PLit (LFlt d)) = putWord8 4 >> put d
|
||||
put (PLit (LInt i)) = putWord8 5 >> put i
|
||||
put (PApp f ps) = putWord8 0 >> put (f,ps)
|
||||
put (PVar x) = putWord8 1 >> put x
|
||||
put PWild = putWord8 2
|
||||
put (PLit l) = putWord8 3 >> put l
|
||||
put (PImplArg p) = putWord8 4 >> put p
|
||||
get = do tag <- getWord8
|
||||
case tag of
|
||||
0 -> liftM2 PApp get get
|
||||
1 -> liftM PVar get
|
||||
2 -> return PWild
|
||||
3 -> liftM (PLit . LStr) get
|
||||
4 -> liftM (PLit . LFlt) get
|
||||
5 -> liftM (PLit . LInt) get
|
||||
3 -> liftM PLit get
|
||||
4 -> liftM PImplArg get
|
||||
_ -> decodingError
|
||||
|
||||
instance Binary Equation where
|
||||
@@ -160,30 +154,65 @@ instance Binary BindType where
|
||||
1 -> return Implicit
|
||||
_ -> decodingError
|
||||
|
||||
instance Binary FFun where
|
||||
put (FFun fun lins) = put (fun,lins)
|
||||
get = liftM2 FFun get get
|
||||
instance Binary CncFun where
|
||||
put (CncFun fun lins) = put fun >> putArray lins
|
||||
get = liftM2 CncFun get getArray
|
||||
|
||||
instance Binary FSymbol where
|
||||
put (FSymCat n l) = putWord8 0 >> put (n,l)
|
||||
put (FSymLit n l) = putWord8 1 >> put (n,l)
|
||||
put (FSymKS ts) = putWord8 2 >> put ts
|
||||
put (FSymKP d vs) = putWord8 3 >> put (d,vs)
|
||||
instance Binary CncCat where
|
||||
put (CncCat s e labels) = do put (s,e)
|
||||
putArray labels
|
||||
get = liftM3 CncCat get get getArray
|
||||
|
||||
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
|
||||
case tag of
|
||||
0 -> liftM2 FSymCat get get
|
||||
1 -> liftM2 FSymLit get get
|
||||
2 -> liftM FSymKS get
|
||||
3 -> liftM2 (\d vs -> FSymKP d vs) get get
|
||||
0 -> liftM2 SymCat get get
|
||||
1 -> liftM2 SymLit get get
|
||||
2 -> liftM SymKS get
|
||||
3 -> liftM2 (\d vs -> SymKP d vs) get get
|
||||
_ -> decodingError
|
||||
|
||||
instance Binary Production where
|
||||
put (FApply ruleid args) = putWord8 0 >> put (ruleid,args)
|
||||
put (FCoerce fcat) = putWord8 1 >> put fcat
|
||||
put (PApply ruleid args) = putWord8 0 >> put (ruleid,args)
|
||||
put (PCoerce fcat) = putWord8 1 >> put fcat
|
||||
get = do tag <- getWord8
|
||||
case tag of
|
||||
0 -> liftM2 FApply get get
|
||||
1 -> liftM FCoerce get
|
||||
0 -> liftM2 PApply get get
|
||||
1 -> liftM PCoerce get
|
||||
_ -> 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"
|
||||
|
||||
@@ -17,48 +17,48 @@ import Data.List
|
||||
-- | An abstract data type representing multilingual grammar
|
||||
-- in Portable Grammar Format.
|
||||
data PGF = PGF {
|
||||
gflags :: Map.Map CId Literal, -- value of a global flag
|
||||
absname :: CId ,
|
||||
cncnames :: [CId] ,
|
||||
gflags :: Map.Map CId String, -- value of a global flag
|
||||
abstract :: Abstr ,
|
||||
concretes :: Map.Map CId Concr
|
||||
}
|
||||
|
||||
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
|
||||
cats :: Map.Map CId [Hypo], -- context of a cat
|
||||
catfuns :: Map.Map CId [CId] -- funs to a cat (redundant, for fast lookup)
|
||||
}
|
||||
|
||||
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
|
||||
functions :: Array FunId FFun,
|
||||
sequences :: Array SeqId FSeq,
|
||||
cncfuns :: Array FunId CncFun,
|
||||
sequences :: Array SeqId Sequence,
|
||||
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
|
||||
cnccats :: Map.Map CId CncCat,
|
||||
totalCats :: {-# UNPACK #-} !FId
|
||||
}
|
||||
|
||||
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]
|
||||
type FId = Int
|
||||
type LIndex = Int
|
||||
type DotPos = Int
|
||||
data Symbol
|
||||
= SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
|
||||
| SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
|
||||
| SymKS [String]
|
||||
| SymKP [String] [Alternative]
|
||||
deriving (Eq,Ord,Show)
|
||||
data Production
|
||||
= FApply {-# UNPACK #-} !FunId [FCat]
|
||||
| FCoerce {-# UNPACK #-} !FCat
|
||||
| FConst Expr [String]
|
||||
= PApply {-# UNPACK #-} !FunId [FId]
|
||||
| PCoerce {-# UNPACK #-} !FId
|
||||
| PConst Expr [String]
|
||||
deriving (Eq,Ord,Show)
|
||||
data FFun = FFun CId {-# UNPACK #-} !(UArray FIndex SeqId) deriving (Eq,Ord,Show)
|
||||
type FSeq = Array FPointPos FSymbol
|
||||
data CncCat = CncCat {-# UNPACK #-} !FId {-# UNPACK #-} !FId {-# UNPACK #-} !(Array LIndex String)
|
||||
data CncFun = CncFun CId {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord,Show)
|
||||
type Sequence = Array DotPos Symbol
|
||||
type FunId = Int
|
||||
type SeqId = Int
|
||||
|
||||
@@ -91,16 +91,14 @@ unionPGF :: PGF -> PGF -> PGF
|
||||
unionPGF one two = case absname one of
|
||||
n | n == wildCId -> two -- extending empty grammar
|
||||
| n == absname two -> one { -- extending grammar with same abstract
|
||||
concretes = Map.union (concretes two) (concretes one),
|
||||
cncnames = union (cncnames one) (cncnames two)
|
||||
concretes = Map.union (concretes two) (concretes one)
|
||||
}
|
||||
_ -> one -- abstracts don't match ---- print error msg
|
||||
|
||||
emptyPGF :: PGF
|
||||
emptyPGF = PGF {
|
||||
absname = wildCId,
|
||||
cncnames = [] ,
|
||||
gflags = Map.empty,
|
||||
absname = wildCId,
|
||||
abstract = error "empty grammar, no abstract",
|
||||
concretes = Map.empty
|
||||
}
|
||||
@@ -126,5 +124,5 @@ fcatInt = (-2)
|
||||
fcatFloat = (-3)
|
||||
fcatVar = (-4)
|
||||
|
||||
isLiteralFCat :: FCat -> Bool
|
||||
isLiteralFCat :: FId -> Bool
|
||||
isLiteralFCat = (`elem` [fcatString, fcatInt, fcatFloat, fcatVar])
|
||||
|
||||
@@ -31,7 +31,7 @@ import qualified Text.ParserCombinators.ReadP as RP
|
||||
|
||||
data Literal =
|
||||
LStr String -- ^ string constant
|
||||
| LInt Integer -- ^ integer constant
|
||||
| LInt Int -- ^ integer constant
|
||||
| LFlt Double -- ^ floating point constant
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
@@ -116,11 +116,11 @@ unStr (ELit (LStr s)) = Just s
|
||||
unStr _ = Nothing
|
||||
|
||||
-- | Constructs an expression from integer literal
|
||||
mkInt :: Integer -> Expr
|
||||
mkInt :: Int -> Expr
|
||||
mkInt i = ELit (LInt i)
|
||||
|
||||
-- | Decomposes an expression into integer literal
|
||||
unInt :: Expr -> Maybe Integer
|
||||
unInt :: Expr -> Maybe Int
|
||||
unInt (ELit (LInt i)) = Just i
|
||||
unInt _ = Nothing
|
||||
|
||||
@@ -236,7 +236,7 @@ ppBind Explicit x = ppCId x
|
||||
ppBind Implicit x = PP.braces (ppCId x)
|
||||
|
||||
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
|
||||
|
||||
ppMeta :: MetaId -> PP.Doc
|
||||
|
||||
@@ -12,7 +12,7 @@ import qualified Data.Set as Set
|
||||
|
||||
-- linearization and computation of concrete PGF Terms
|
||||
|
||||
type LinTable = Array FIndex [Tokn]
|
||||
type LinTable = Array LIndex [Tokn]
|
||||
|
||||
linearizes :: PGF -> CId -> Expr -> [String]
|
||||
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 set -> do prod <- Set.toList set
|
||||
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)
|
||||
let (FFun _ lins) = functions cnc ! funid
|
||||
let (CncFun _ lins) = cncfuns cnc ! funid
|
||||
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 -> apply path xs mb_fid _V [ELit (LStr "?")] -- function without linearization
|
||||
where
|
||||
@@ -63,17 +63,17 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e
|
||||
| f == _B || f == _V = path
|
||||
| otherwise = i:path
|
||||
|
||||
isApp (FApply _ _) = True
|
||||
isApp (PApply _ _) = True
|
||||
isApp _ = False
|
||||
|
||||
computeSeq seqid args = concatMap compute (elems seq)
|
||||
where
|
||||
seq = sequences cnc ! seqid
|
||||
|
||||
compute (FSymCat d r) = (args !! d) ! r
|
||||
compute (FSymLit d r) = (args !! d) ! r
|
||||
compute (FSymKS ts) = map KS ts
|
||||
compute (FSymKP ts alts) = [KP ts alts]
|
||||
compute (SymCat d r) = (args !! d) ! r
|
||||
compute (SymLit d r) = (args !! d) ! r
|
||||
compute (SymKS ts) = map KS ts
|
||||
compute (SymKP ts alts) = [KP ts alts]
|
||||
|
||||
untokn :: [Tokn] -> [String]
|
||||
untokn ts = case ts of
|
||||
@@ -92,9 +92,9 @@ 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 Map.lookup cat (startCats (lookConcr pgf lang)) of
|
||||
Just (_,_,lbls) -> elems lbls
|
||||
Nothing -> error "No labels"
|
||||
in case Map.lookup cat (cnccats (lookConcr pgf lang)) of
|
||||
Just (CncCat _ _ lbls) -> elems lbls
|
||||
Nothing -> error "No labels"
|
||||
Nothing -> error "Not function application"
|
||||
|
||||
|
||||
|
||||
@@ -37,22 +37,22 @@ lookValCat :: PGF -> CId -> CId
|
||||
lookValCat pgf = valCat . lookType pgf
|
||||
|
||||
lookStartCat :: PGF -> CId
|
||||
lookStartCat pgf = mkCId $ fromMaybe "S" $ msum $ Data.List.map (Map.lookup (mkCId "startcat"))
|
||||
[gflags pgf, aflags (abstract pgf)]
|
||||
lookStartCat pgf = mkCId $
|
||||
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 f =
|
||||
lookMap "?" f (gflags pgf)
|
||||
lookGlobalFlag :: PGF -> CId -> Maybe Literal
|
||||
lookGlobalFlag pgf f = Map.lookup f (gflags pgf)
|
||||
|
||||
lookAbsFlag :: PGF -> CId -> String
|
||||
lookAbsFlag pgf f =
|
||||
lookMap "?" f (aflags (abstract pgf))
|
||||
lookAbsFlag :: PGF -> CId -> Maybe Literal
|
||||
lookAbsFlag pgf f = Map.lookup f (aflags (abstract pgf))
|
||||
|
||||
lookConcr :: PGF -> CId -> Concr
|
||||
lookConcr pgf cnc =
|
||||
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
|
||||
|
||||
functionsToCat :: PGF -> CId -> [(CId,Type)]
|
||||
@@ -142,8 +142,13 @@ _B = mkCId "__gfB"
|
||||
_V = mkCId "__gfV"
|
||||
|
||||
updateProductionIndices :: PGF -> PGF
|
||||
updateProductionIndices pgf = pgf{concretes = fmap updateConcrete (concretes pgf)}
|
||||
updateProductionIndices pgf = pgf{ abstract = updateAbstract (abstract pgf)
|
||||
, concretes = fmap updateConcrete (concretes pgf)
|
||||
}
|
||||
where
|
||||
updateAbstract abs =
|
||||
abs{catfuns = Map.mapWithKey (\cat _ -> [f | (f, (DTyp _ c _,_,_)) <- Map.toList (funs abs), c==cat]) (cats abs)}
|
||||
|
||||
updateConcrete cnc =
|
||||
let prods0 = filterProductions (productions cnc)
|
||||
p_prods = parseIndex cnc prods0
|
||||
@@ -162,8 +167,8 @@ updateProductionIndices pgf = pgf{concretes = fmap updateConcrete (concretes pgf
|
||||
where
|
||||
set = Set.filter (filterRule prods) set0
|
||||
|
||||
filterRule prods (FApply funid args) = all (\fcat -> isLiteralFCat fcat || IntMap.member fcat prods) args
|
||||
filterRule prods (FCoerce fcat) = isLiteralFCat fcat || IntMap.member fcat prods
|
||||
filterRule prods (PApply funid args) = all (\fcat -> isLiteralFCat fcat || IntMap.member fcat prods) args
|
||||
filterRule prods (PCoerce fcat) = isLiteralFCat fcat || IntMap.member fcat prods
|
||||
filterRule prods _ = True
|
||||
|
||||
parseIndex pinfo = IntMap.mapMaybeWithKey filterProdSet
|
||||
@@ -175,12 +180,12 @@ updateProductionIndices pgf = pgf{concretes = fmap updateConcrete (concretes pgf
|
||||
then Nothing
|
||||
else Just prods'
|
||||
|
||||
is_ho_prod (FApply _ [fid]) | fid == fcatVar = True
|
||||
is_ho_prod (PApply _ [fid]) | fid == fcatVar = True
|
||||
is_ho_prod _ = False
|
||||
|
||||
ho_fids :: IntSet.IntSet
|
||||
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 = sortNub [c | (ty,_,_) <- Map.elems (funs (abstract pgf))
|
||||
@@ -194,7 +199,7 @@ updateProductionIndices pgf = pgf{concretes = fmap updateConcrete (concretes pgf
|
||||
, prod <- Set.toList prods
|
||||
, fun <- getFunctions prod]
|
||||
where
|
||||
getFunctions (FApply funid args) = let FFun fun _ = functions pinfo Array.! funid in [fun]
|
||||
getFunctions (FCoerce fid) = case IntMap.lookup fid productions of
|
||||
getFunctions (PApply funid args) = let CncFun fun _ = cncfuns pinfo Array.! funid in [fun]
|
||||
getFunctions (PCoerce fid) = case IntMap.lookup fid productions of
|
||||
Nothing -> []
|
||||
Just prods -> [fun | prod <- Set.toList prods, fun <- getFunctions prod]
|
||||
@@ -25,17 +25,17 @@ buildMorpho pgf lang = Morpho $
|
||||
Nothing -> Map.empty
|
||||
|
||||
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]
|
||||
, FApply funid _ <- maybe [] Set.toList (IntMap.lookup fid (pproductions pinfo))
|
||||
, let FFun fun lins = functions pinfo ! funid
|
||||
, PApply funid _ <- maybe [] Set.toList (IntMap.lookup fid (pproductions pinfo))
|
||||
, let CncFun fun lins = cncfuns pinfo ! funid
|
||||
, (l,seqid) <- assocs lins
|
||||
, sym <- elems (sequences pinfo ! seqid)
|
||||
, t <- sym2tokns sym]
|
||||
where
|
||||
sym2tokns (FSymKS ts) = ts
|
||||
sym2tokns (FSymKP ts alts) = ts ++ [t | Alt ts ps <- alts, t <- ts]
|
||||
sym2tokns _ = []
|
||||
sym2tokns (SymKS ts) = ts
|
||||
sym2tokns (SymKP ts alts) = ts ++ [t | Alt ts ps <- alts, t <- ts]
|
||||
sym2tokns _ = []
|
||||
|
||||
lookupMorpho :: Morpho -> String -> [(Lemma,Analysis)]
|
||||
lookupMorpho (Morpho mo) s = maybe [] id $ Map.lookup s mo
|
||||
|
||||
@@ -56,14 +56,14 @@ 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 cnc) of
|
||||
Just (s,e,labels) -> do cat <- range (s,e)
|
||||
(funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args)
|
||||
[] 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
|
||||
let items = case Map.lookup start (cnccats cnc) of
|
||||
Just (CncCat s e labels) -> do cat <- range (s,e)
|
||||
(funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args)
|
||||
[] cat (pproductions cnc)
|
||||
let CncFun fn lins = cncfuns cnc ! funid
|
||||
(lbl,seqid) <- assocs lins
|
||||
return (Active 0 0 funid seqid args (AK cat lbl))
|
||||
Nothing -> mzero
|
||||
|
||||
cnc = lookConcr pgf lang
|
||||
|
||||
@@ -82,7 +82,7 @@ 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 cnc) (functions cnc) agenda acc chart
|
||||
(acc1,chart1) = process (Just t) add (sequences cnc) (cncfuns cnc) agenda acc chart
|
||||
chart2 = chart1{ active =emptyAC
|
||||
, actives=active chart1 : actives chart1
|
||||
, passive=emptyPC
|
||||
@@ -105,7 +105,7 @@ 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 cnc) (functions cnc) agenda acc chart
|
||||
(acc',chart1) = process Nothing add (sequences cnc) (cncfuns cnc) agenda acc chart
|
||||
chart2 = chart1{ active =emptyAC
|
||||
, actives=active chart1 : actives chart1
|
||||
, passive=emptyPC
|
||||
@@ -121,7 +121,7 @@ recoveryStates :: [Type] -> ErrorState -> (ParseState, Map.Map String ParseState
|
||||
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 cnc) (functions cnc) agenda Map.empty chart
|
||||
(acc,chart1) = process Nothing add (sequences cnc) (cncfuns cnc) agenda Map.empty chart
|
||||
chart2 = chart1{ active =emptyAC
|
||||
, actives=active chart1 : actives chart1
|
||||
, 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)
|
||||
where
|
||||
type2fcats (DTyp _ cat _) = case Map.lookup cat (startCats cnc) of
|
||||
Just (s,e,labels) -> range (s,e)
|
||||
Nothing -> []
|
||||
type2fcats (DTyp _ cat _) = case Map.lookup cat (cnccats cnc) of
|
||||
Just (CncCat s e labels) -> range (s,e)
|
||||
Nothing -> []
|
||||
|
||||
complete open_fcats items ac =
|
||||
foldl (Set.fold (\(Active j' ppos funid seqid args keyc) ->
|
||||
@@ -151,23 +151,23 @@ extractTrees (PState pgf cnc chart items) ty@(DTyp _ start _) =
|
||||
where
|
||||
(mb_agenda,acc) = TMap.decompose items
|
||||
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 =
|
||||
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)]
|
||||
(fvs,tree) <- go Set.empty 0 (0,fid)
|
||||
guard (Set.null fvs)
|
||||
return tree
|
||||
Nothing -> mzero
|
||||
case Map.lookup start (cnccats cnc) of
|
||||
Just (CncCat s e lbls) -> do cat <- range (s,e)
|
||||
lbl <- indices lbls
|
||||
Just fid <- [lookupPC (PK cat lbl 0) (passive st)]
|
||||
(fvs,tree) <- go Set.empty 0 (0,fid)
|
||||
guard (Set.null fvs)
|
||||
return tree
|
||||
Nothing -> mzero
|
||||
|
||||
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
|
||||
| Set.member fcat rec = mzero
|
||||
| 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)
|
||||
check_ho_fun fn args
|
||||
`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
|
||||
| inRange (bounds lin) ppos =
|
||||
case unsafeAt lin ppos of
|
||||
FSymCat d r -> let !fid = args !! d
|
||||
key = AK fid r
|
||||
SymCat d r -> let !fid = args !! d
|
||||
key = AK fid r
|
||||
|
||||
items2 = case lookupPC (mkPK key k) (passive chart) of
|
||||
Nothing -> 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)
|
||||
(\_ _ items -> items)
|
||||
items2 fid (forest chart)
|
||||
in case lookupAC key (active chart) of
|
||||
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
|
||||
| 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
|
||||
in process mbt fn seqs funs items acc' chart
|
||||
FSymKP strs vars
|
||||
-> let !acc' = foldl (\acc toks -> fn toks (Active j (ppos+1) funid seqid args key0) acc) acc
|
||||
(strs:[strs' | Alt strs' _ <- vars])
|
||||
in process mbt fn seqs funs items acc' chart
|
||||
FSymLit d r -> let !fid = args !! d
|
||||
in case [ts | FConst _ ts <- maybe [] Set.toList (IntMap.lookup fid (forest chart))] of
|
||||
(toks:_) -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc
|
||||
in process mbt fn seqs funs items acc' chart
|
||||
[] -> case litCatMatch fid mbt of
|
||||
Just (toks,lit) -> let fid' = nextId chart
|
||||
!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)
|
||||
,nextId=nextId chart+1
|
||||
}
|
||||
Nothing -> process mbt fn seqs funs items acc chart
|
||||
items2 = case lookupPC (mkPK key k) (passive chart) of
|
||||
Nothing -> 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)
|
||||
(\_ _ items -> items)
|
||||
items2 fid (forest chart)
|
||||
in case lookupAC key (active chart) of
|
||||
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
|
||||
| otherwise -> process mbt fn seqs funs items2 acc chart{active=insertAC key (Set.insert item set) (active chart)}
|
||||
SymKS toks -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc
|
||||
in process mbt fn seqs funs items acc' chart
|
||||
SymKP strs vars
|
||||
-> let !acc' = foldl (\acc toks -> fn toks (Active j (ppos+1) funid seqid args key0) acc) acc
|
||||
(strs:[strs' | Alt strs' _ <- vars])
|
||||
in process mbt fn seqs funs items acc' chart
|
||||
SymLit d r -> let !fid = args !! d
|
||||
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
|
||||
in process mbt fn seqs funs items acc' chart
|
||||
[] -> case litCatMatch fid mbt of
|
||||
Just (toks,lit) -> let fid' = nextId chart
|
||||
!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 (PConst lit toks)) (forest chart)
|
||||
,nextId=nextId chart+1
|
||||
}
|
||||
Nothing -> process mbt fn seqs funs items acc chart
|
||||
| otherwise =
|
||||
case lookupPC (mkPK key0 j) (passive chart) of
|
||||
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
|
||||
Nothing -> items
|
||||
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 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
|
||||
}
|
||||
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
|
||||
!lin = unsafeAt seqs seqid
|
||||
!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
|
||||
where
|
||||
FFun _ lins = unsafeAt funs funid
|
||||
CncFun _ lins = unsafeAt funs funid
|
||||
|
||||
|
||||
updateAt :: Int -> a -> [a] -> [a]
|
||||
@@ -268,15 +268,15 @@ litCatMatch _ _ = Nothing
|
||||
|
||||
data Active
|
||||
= Active {-# UNPACK #-} !Int
|
||||
{-# UNPACK #-} !FPointPos
|
||||
{-# UNPACK #-} !DotPos
|
||||
{-# UNPACK #-} !FunId
|
||||
{-# UNPACK #-} !SeqId
|
||||
[FCat]
|
||||
[FId]
|
||||
{-# UNPACK #-} !ActiveKey
|
||||
deriving (Eq,Show,Ord)
|
||||
data ActiveKey
|
||||
= AK {-# UNPACK #-} !FCat
|
||||
{-# UNPACK #-} !FIndex
|
||||
= AK {-# UNPACK #-} !FId
|
||||
{-# UNPACK #-} !LIndex
|
||||
deriving (Eq,Ord,Show)
|
||||
type ActiveChart = IntMap.IntMap (IntMap.IntMap (Set.Set Active))
|
||||
|
||||
@@ -286,13 +286,13 @@ emptyAC = IntMap.empty
|
||||
lookupAC :: ActiveKey -> ActiveChart -> Maybe (Set.Set Active)
|
||||
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 =
|
||||
case IntMap.lookup fcat chart of
|
||||
Nothing -> []
|
||||
Just map -> IntMap.elems map
|
||||
|
||||
labelsAC :: FCat -> ActiveChart -> [FIndex]
|
||||
labelsAC :: FId -> ActiveChart -> [LIndex]
|
||||
labelsAC fcat chart =
|
||||
case IntMap.lookup fcat chart of
|
||||
Nothing -> []
|
||||
@@ -307,20 +307,20 @@ insertAC (AK fcat l) set chart = IntMap.insertWith IntMap.union fcat (IntMap.sin
|
||||
----------------------------------------------------------------
|
||||
|
||||
data PassiveKey
|
||||
= PK {-# UNPACK #-} !FCat
|
||||
{-# UNPACK #-} !FIndex
|
||||
= PK {-# UNPACK #-} !FId
|
||||
{-# UNPACK #-} !LIndex
|
||||
{-# UNPACK #-} !Int
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
type PassiveChart = Map.Map PassiveKey FCat
|
||||
type PassiveChart = Map.Map PassiveKey FId
|
||||
|
||||
emptyPC :: PassiveChart
|
||||
emptyPC = Map.empty
|
||||
|
||||
lookupPC :: PassiveKey -> PassiveChart -> Maybe FCat
|
||||
lookupPC :: PassiveKey -> PassiveChart -> Maybe FId
|
||||
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
|
||||
|
||||
|
||||
@@ -328,15 +328,15 @@ insertPC key fcat chart = Map.insert key fcat chart
|
||||
-- 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 =
|
||||
case IntMap.lookup fcat forest of
|
||||
Nothing -> b
|
||||
Just set -> Set.fold foldProd b set
|
||||
where
|
||||
foldProd (FCoerce fcat) b = foldForest f g b fcat forest
|
||||
foldProd (FApply funid args) b = f funid args b
|
||||
foldProd (FConst const toks) b = g const toks b
|
||||
foldProd (PCoerce fcat) b = foldForest f g b fcat forest
|
||||
foldProd (PApply funid args) b = f funid args b
|
||||
foldProd (PConst const toks) b = g const toks b
|
||||
|
||||
|
||||
----------------------------------------------------------------
|
||||
@@ -353,7 +353,7 @@ data Chart
|
||||
, actives :: [ActiveChart]
|
||||
, passive :: PassiveChart
|
||||
, forest :: IntMap.IntMap (Set.Set Production)
|
||||
, nextId :: {-# UNPACK #-} !FCat
|
||||
, nextId :: {-# UNPACK #-} !FId
|
||||
, offset :: {-# UNPACK #-} !Int
|
||||
}
|
||||
deriving Show
|
||||
|
||||
@@ -40,34 +40,34 @@ ppCnc name cnc =
|
||||
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)))) $$
|
||||
nest 2 (vcat (map ppCncFun (assocs (cncfuns cnc)))) $$
|
||||
text "sequences" $$
|
||||
nest 2 (vcat (map ppSeq (assocs (sequences cnc)))) $$
|
||||
text "startcats" $$
|
||||
nest 2 (vcat (map ppStartCat (Map.toList (startCats cnc))))) $$
|
||||
text "categories" $$
|
||||
nest 2 (vcat (map ppCncCat (Map.toList (cnccats cnc))))) $$
|
||||
char '}'
|
||||
|
||||
ppProduction (fcat,FApply funid args) =
|
||||
ppProduction (fcat,PApply funid 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)
|
||||
ppProduction (fcat,FConst _ ss) =
|
||||
ppProduction (fcat,PConst _ 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)
|
||||
|
||||
ppSeq (seqid,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) $$
|
||||
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)))
|
||||
ppSymbol (SymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
|
||||
ppSymbol (SymLit d r) = char '<' <> int d <> comma <> int r <> char '>'
|
||||
ppSymbol (SymKS ts) = ppStrs ts
|
||||
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)
|
||||
|
||||
|
||||
@@ -238,7 +238,7 @@ mtag = tag . ('n':) . uncommas
|
||||
|
||||
graphvizAlignment :: PGF -> Expr -> String
|
||||
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 ss = trace (show ss) $ prelude ++ nodes ++ links
|
||||
|
||||
Reference in New Issue
Block a user