From e51eaed4fde9f2bee962ed43f5b9a8592e76a947 Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Thu, 1 Jun 2006 11:19:47 +0000 Subject: add the FCFG parser --- src/GF/Conversion/SimpleToFCFG.hs | 459 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 459 insertions(+) create mode 100644 src/GF/Conversion/SimpleToFCFG.hs (limited to 'src/GF/Conversion/SimpleToFCFG.hs') diff --git a/src/GF/Conversion/SimpleToFCFG.hs b/src/GF/Conversion/SimpleToFCFG.hs new file mode 100644 index 000000000..a41c7e92f --- /dev/null +++ b/src/GF/Conversion/SimpleToFCFG.hs @@ -0,0 +1,459 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/08/17 08:27:29 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.7 $ +-- +-- Converting SimpleGFC grammars to fast nonerasing MCFG grammar. +-- +-- the resulting grammars might be /very large/ +-- +-- the conversion is only equivalent if the GFC grammar has a context-free backbone. +----------------------------------------------------------------------------- + + +module GF.Conversion.SimpleToFCFG + (convertGrammar) where + +import GF.System.Tracing +import GF.Infra.Print +import GF.Infra.Ident + +import Control.Monad + +import GF.Formalism.Utilities +import GF.Formalism.GCFG +import GF.Formalism.FCFG +import GF.Formalism.MCFG(Lin(..)) +import GF.Formalism.SimpleGFC +import GF.Conversion.Types +import GF.Canon.AbsGFC(CIdent(..)) + +import GF.Data.BacktrackM +import GF.Data.SortedList +import GF.Data.Utilities (updateNthM) + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.List as List +import Data.Array + +---------------------------------------------------------------------- +-- main conversion function + +convertGrammar :: SGrammar -> FGrammar +convertGrammar srules = getFRules (loop frulesEnv) + where + (srulesMap,frulesEnv) = foldl helper (Map.empty,emptyFRulesEnv) srules + where + helper (srulesMap,frulesEnv) rule@(Rule (Abs decl _ _) (Cnc ctype _ _)) = + ( Map.insertWith (++) (decl2cat decl) [rule] srulesMap + , foldBM (\selector _ env -> convertRule selector rule env) + frulesEnv + (mkSingletonSelector ctype) + () + ) + + loop frulesEnv = + let (todo, frulesEnv') = takeToDoRules srulesMap frulesEnv + in case todo of + [] -> frulesEnv' + _ -> loop $! foldl (\env (srules,selector) -> + foldl (\env srule -> convertRule selector srule env) env srules) frulesEnv' todo + + +---------------------------------------------------------------------- +-- rule conversion + +convertRule :: STermSelector -> SRule -> FRulesEnv -> FRulesEnv +convertRule selector (Rule (Abs decl decls (Name fun profile)) (Cnc ctype ctypes (Just term))) frulesEnv = + foldBM addRule + frulesEnv + (convertTerm selector term [Lin emptyPath []]) + (let cat : args = map decl2cat (decl : decls) + in (initialFCat cat, map initialFCat args, ctype, ctypes)) + where + addRule linRec (newCat', newArgs', _, _) env0 = + let (env1, newCat) = genFCatHead env0 newCat' + (env2, newArgs,idxArgs) = foldr (\(fcat,ctype,idx) (env,args,all_args) -> + let (env1, fcat1) = genFCatArg env fcat ctype + in case fcat of + FCat _ _ [] _ -> (env , args, all_args) + _ -> (env1,fcat1:args,(idx,fcat1):all_args)) (env1,[],[]) (zip3 newArgs' ctypes [0..]) + + (catPaths : argsPaths) = [rcs | (FCat _ _ rcs _) <- (newCat : newArgs)] + + newLinRec = listArray (0,length linRec-1) [translateLin idxArgs path linRec | path <- catPaths] + + (_,newProfile) = List.mapAccumL accumProf 0 newArgs' + where + accumProf nr (FCat _ _ [] _) = (nr, Unify [] ) + accumProf nr _ = (nr+1, Unify [nr]) + + newName = Name fun (profile `composeProfiles` newProfile) + rule = FRule (Abs newCat newArgs (Name fun newProfile)) newLinRec + in addFCatRule env2 rule +convertRule selector _ frulesEnv = frulesEnv + +translateLin idxArgs lbl' [] = array (0,-1) [] +translateLin idxArgs lbl' (Lin lbl syms : lins) + | lbl' == lbl = listArray (0,length syms-1) (map instSym syms) + | otherwise = translateLin idxArgs lbl' lins + where instSym = symbol (\(_, lbl, nr) -> instCat lbl nr 0 idxArgs) FSymTok + instCat lbl nr nr' ((idx,arg@(FCat _ _ rcs _)):idxArgs) + | nr == idx = FSymCat arg (index lbl rcs 0) nr' + | otherwise = instCat lbl nr (nr'+1) idxArgs + + index lbl' (lbl:lbls) idx + | lbl' == lbl = idx + | otherwise = index lbl' lbls $! (idx+1) + +---------------------------------------------------------------------- +-- term conversion + +type CnvMonad a = BacktrackM Env a + +type Env = (FCat, [FCat], SLinType, [SLinType]) +type LinRec = [Lin SCat SPath Token] + + +convertTerm :: STermSelector -> STerm -> LinRec -> CnvMonad LinRec +convertTerm selector (Arg nr cat path) (Lin lbl_path lin : lins) = convertArg selector nr cat path lbl_path lin lins +convertTerm selector (con :^ args) (Lin lbl_path lin : lins) = convertCon selector con args lbl_path lin lins +convertTerm selector (Rec record) (Lin lbl_path lin : lins) = convertRec selector record lbl_path lin lins +convertTerm selector (term :. lbl) lins = convertTerm (RecPrj lbl selector) term lins +convertTerm selector (Tbl table) (Lin lbl_path lin : lins) = convertTbl selector table lbl_path lin lins +convertTerm selector (term :! sel) lins = do sel <- evalTerm sel + convertTerm (TblPrj sel selector) term lins +convertTerm selector (Variants vars) lins = do term <- member vars + convertTerm selector term lins +convertTerm selector (t1 :++ t2) lins = do lins <- convertTerm selector t2 lins + lins <- convertTerm selector t1 lins + return lins +convertTerm selector (Token str) (Lin lbl_path lin : lins) = do projectHead lbl_path + return (Lin lbl_path (Tok str : lin) : lins) +convertTerm selector (Empty ) (Lin lbl_path lin : lins) = do projectHead lbl_path + return (Lin lbl_path lin : lins) + +convertArg (RecSel record) nr cat path lbl_path lin lins = + foldM (\lins (lbl, selector) -> convertArg selector nr cat (path ++. lbl) (lbl_path ++. lbl) lin lins) lins record +convertArg (TblSel cases) nr cat path lbl_path lin lins = + foldM (\lins (term, selector) -> convertArg selector nr cat (path ++! term) (lbl_path ++! term) lin lins) lins cases +convertArg (RecPrj lbl selector) nr cat path lbl_path lin lins = + convertArg selector nr cat (path ++. lbl ) lbl_path lin lins +convertArg (TblPrj term selector) nr cat path lbl_path lin lins = + convertArg selector nr cat (path ++! term) lbl_path lin lins +convertArg (ConSel terms) nr cat path lbl_path lin lins = do + sel <- member terms + restrictHead lbl_path sel + restrictArg nr lbl_path sel + return lins +convertArg StrSel nr cat path lbl_path lin lins = do + projectHead lbl_path + projectArg nr path + return (Lin lbl_path (Cat (cat, path, nr) : lin) : lins) + +convertCon (ConSel terms) con args lbl_path lin lins = do + args <- mapM evalTerm args + let term = con :^ args + guard (term `elem` terms) + restrictHead lbl_path term + return lins + +convertRec selector [] lbl_path lin lins = return lins +convertRec selector@(RecSel fields) ((label, val):record) lbl_path lin lins = select fields + where + select [] = convertRec selector record lbl_path lin lins + select ((label',sub_sel) : fields) + | label == label' = do lins <- convertTerm sub_sel val (Lin (lbl_path ++. label) lin : lins) + convertRec selector record lbl_path lin lins + | otherwise = select fields +convertRec (RecPrj label sub_sel) record lbl_path lin lins = do + (label',val) <- member record + guard (label==label') + convertTerm sub_sel val (Lin lbl_path lin : lins) + +convertTbl selector [] lbl_path lin lins = return lins +convertTbl selector@(TblSel cases) ((term, val):table) lbl_path lin lins = case selector of { TblSel cases -> select cases } + where + select [] = convertTbl selector table lbl_path lin lins + select ((term',sub_sel) : cases) + | term == term' = do lins <- convertTerm sub_sel val (Lin (lbl_path ++! term) lin : lins) + convertTbl selector table lbl_path lin lins + | otherwise = select cases +convertTbl (TblPrj term sub_sel) table lbl_path lin lins = do + (term',val) <- member table + guard (term==term') + convertTerm sub_sel val (Lin lbl_path lin : lins) + + +------------------------------------------------------------ +-- eval a term to ground terms + +evalTerm :: STerm -> CnvMonad STerm +evalTerm arg@(Arg nr _ path) = do ctype <- readArgCType nr + unifyPType arg $ lintypeFollowPath path ctype +evalTerm (con :^ terms) = do terms <- mapM evalTerm terms + return (con :^ terms) +evalTerm (Rec record) = do record <- mapM evalAssign record + return (Rec record) +evalTerm (term :. lbl) = do term <- evalTerm term + evalTerm (term +. lbl) +evalTerm (Tbl table) = do table <- mapM evalCase table + return (Tbl table) +evalTerm (term :! sel) = do sel <- evalTerm sel + evalTerm (term +! sel) +evalTerm (Variants terms) = member terms >>= evalTerm +evalTerm (t1 :++ t2) = do t1 <- evalTerm t1 + t2 <- evalTerm t2 + return (t1 :++ t2) +evalTerm (Token str) = do return (Token str) +evalTerm Empty = do return Empty + +evalAssign :: (Label, STerm) -> CnvMonad (Label, STerm) +evalAssign (lbl, term) = liftM ((,) lbl) $ evalTerm term + +evalCase :: (STerm, STerm) -> CnvMonad (STerm, STerm) +evalCase (pat, term) = liftM2 (,) (evalTerm pat) (evalTerm term) + +unifyPType :: STerm -> SLinType -> CnvMonad STerm +unifyPType arg (RecT prec) = + liftM Rec $ + sequence [ liftM ((,) lbl) $ + unifyPType (arg +. lbl) ptype | + (lbl, ptype) <- prec ] +unifyPType (Arg nr _ path) (ConT terms) = + do (_, args, _, _) <- readState + let (FCat _ _ _ tcs) = args !! nr + case lookup path tcs of + Just term -> return term + Nothing -> do term <- member terms + restrictArg nr path term + return term + + +---------------------------------------------------------------------- +-- FRulesEnv + +data FRulesEnv = FRulesEnv {-# UNPACK #-} !Int FCatSet [FRule] + +type SRulesMap = Map.Map SCat [SRule] +type FCatSet = Map.Map SCat (Map.Map [SPath] (Map.Map [(SPath,STerm)] (Either FCat FCat))) + + +emptyFRulesEnv = FRulesEnv 0 Map.empty [] + +genFCatHead :: FRulesEnv -> FCat -> (FRulesEnv, FCat) +genFCatHead env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat rcs tcs) = + case Map.lookup cat fcatSet >>= Map.lookup rcs >>= Map.lookup tcs of + Just (Left fcat) -> (FRulesEnv last_id (ins fcat) rules, fcat) + Just (Right fcat) -> (env, fcat) + Nothing -> let next_id = last_id+1 + fcat = FCat next_id cat rcs tcs + in (FRulesEnv next_id (ins fcat) rules, fcat) + where + ins fcat = Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs x_fcat) rcs tmap_s) cat rmap_s fcatSet + where + x_fcat = Right fcat + tmap_s = Map.singleton tcs x_fcat + rmap_s = Map.singleton rcs tmap_s + +genFCatArg :: FRulesEnv -> FCat -> SLinType -> (FRulesEnv, FCat) +genFCatArg env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat rcs tcs) ctype = + case Map.lookup cat fcatSet >>= Map.lookup rcs of + Just tmap -> case Map.lookup tcs tmap of + Just (Left fcat) -> (env, fcat) + Just (Right fcat) -> (env, fcat) + Nothing -> ins tmap + Nothing -> ins Map.empty + where + ins tmap = + let next_id = last_id+1 + fcat = FCat next_id cat rcs tcs + (x_fcat,last_id1,tmap1,rules1) + = foldBM (\tcs st (x_fcat,last_id,tmap,rules) -> + let (last_id1,tmap1,fcat_arg) = addArg tcs last_id tmap + rule = FRule (Abs fcat [fcat_arg] coercionName) + (listArray (0,length rcs-1) [listArray (0,0) [FSymCat fcat_arg lbl 0] | lbl <- [0..length rcs-1]]) + in if st + then (Right fcat,last_id1,tmap1,rule:rules) + else (x_fcat, last_id, tmap, rules)) + (Left fcat,next_id,Map.insert tcs x_fcat tmap,rules) + (gen_tcs ctype emptyPath []) + False + rmap1 = Map.singleton rcs tmap1 + in (FRulesEnv last_id1 (Map.insertWith (\_ -> Map.insert rcs tmap1) cat rmap1 fcatSet) rules1, fcat) + where + addArg tcs last_id tmap = + case Map.lookup tcs tmap of + Just (Left fcat) -> (last_id, tmap, fcat) + Just (Right fcat) -> (last_id, tmap, fcat) + Nothing -> let next_id = last_id+1 + fcat = FCat next_id cat rcs tcs + in (next_id, Map.insert tcs (Left fcat) tmap, fcat) + + gen_tcs :: SLinType -> SPath -> [(SPath,STerm)] -> BacktrackM Bool [(SPath,STerm)] + gen_tcs (RecT record) path acc = foldM (\acc (label,ctype) -> gen_tcs ctype (path ++. label) acc) acc record + gen_tcs (TblT terms ctype) path acc = foldM (\acc term -> gen_tcs ctype (path ++! term ) acc) acc terms + gen_tcs (StrT) path acc = return acc + gen_tcs (ConT terms) path acc = + case List.lookup path tcs of + Just term -> return ((path,term) : acc) + Nothing -> do writeState True + term <- member terms + return ((path,term) : acc) + +takeToDoRules :: SRulesMap -> FRulesEnv -> ([([SRule], STermSelector)], FRulesEnv) +takeToDoRules srulesMap (FRulesEnv last_id fcatSet rules) = (todo,FRulesEnv last_id fcatSet' rules) + where + (todo,fcatSet') = + Map.mapAccumWithKey (\todo cat rmap -> + let (todo1,rmap1) = Map.mapAccumWithKey (\todo rcs tmap -> + let (tcss,tmap') = Map.mapAccumWithKey (\tcss tcs x_fcat -> + case x_fcat of + Left fcat -> (tcs:tcss,Right fcat) + Right fcat -> ( tcss, x_fcat)) [] tmap + in case tcss of + [] -> ( todo,tmap ) + _ -> ((srules,mkSelector rcs tcss) : todo,tmap')) todo rmap + mb_srules = Map.lookup cat srulesMap + Just srules = mb_srules + + in case mb_srules of + Just srules -> (todo1,rmap1) + Nothing -> (todo ,rmap1)) [] fcatSet + +addFCatRule :: FRulesEnv -> FRule -> FRulesEnv +addFCatRule (FRulesEnv last_id fcatSet rules) rule = FRulesEnv last_id fcatSet (rule:rules) + +getFRules :: FRulesEnv -> [FRule] +getFRules (FRulesEnv last_id fcatSet rules) = rules + + +------------------------------------------------------------ +-- The STermSelector + +data STermSelector + = RecSel [(Label, STermSelector)] + | TblSel [(STerm, STermSelector)] + | RecPrj Label STermSelector + | TblPrj STerm STermSelector + | ConSel [STerm] + | StrSel + deriving Show + + +mkSingletonSelector :: SLinType -> BacktrackM () STermSelector +mkSingletonSelector ctype = do + let (rcss,tcss) = loop emptyPath ([],[]) ctype + rcs <- member rcss + return (mkSelector [rcs] tcss) + where + loop path st (RecT record) = foldl (\st (lbl,ctype) -> loop (path ++. lbl ) st ctype) st record + loop path st (TblT terms ctype) = foldl (\st term -> loop (path ++! term) st ctype) st terms + loop path (rcss,tcss) (ConT terms) = (rcss, map ((,) path) terms : tcss) + loop path (rcss,tcss) (StrT) = (path : rcss, tcss) + + +mkSelector :: [SPath] -> [[(SPath,STerm)]] -> STermSelector +mkSelector rcs tcss = + foldl addRestriction (case xs of + (path:xs) -> foldl addProjection (path2selector StrSel path) xs) ys + where + xs = [ reverse path | Path path <- rcs] + ys = [(reverse path,term) | tcs <- tcss, (Path path,term) <- tcs] + + addProjection :: STermSelector -> [Either Label STerm] -> STermSelector + addProjection StrSel [] = StrSel + addProjection (RecSel fields) (Left lbl : path) = RecSel (add fields) + where + add [] = [(lbl,path2selector StrSel path)] + add (field@(lbl',sub_sel):fields) + | lbl == lbl' = (lbl',addProjection sub_sel path):fields + | otherwise = field : add fields + addProjection (TblSel cases) (Right pat : path) = TblSel (add cases) + where + add [] = [(pat,path2selector StrSel path)] + add (cas@(pat',sub_sel):cases) + | pat == pat' = (pat',addProjection sub_sel path):cases + | otherwise = cas : add cases + addProjection x y = error ("addProjection "++show x ++ " " ++ prt (Path y)) + + addRestriction :: STermSelector -> ([Either Label STerm],STerm) -> STermSelector + addRestriction (ConSel terms) ([] ,term) = ConSel (term:terms) + addRestriction (RecSel fields) (Left lbl : path,term) = RecSel (add fields) + where + add [] = [(lbl,path2selector (ConSel [term]) path)] + add (field@(lbl',sub_sel):fields) + | lbl == lbl' = (lbl',addRestriction sub_sel (path,term)):fields + | otherwise = field : add fields + addRestriction (TblSel cases) (Right pat : path,term) = TblSel (add cases) + where + add [] = [(pat,path2selector (ConSel [term]) path)] + add (field@(pat',sub_sel):cases) + | pat == pat' = (pat',addRestriction sub_sel (path,term)):cases + | otherwise = field : add cases + + path2selector base [] = base + path2selector base (Left lbl : path) = RecSel [(lbl,path2selector base path)] + path2selector base (Right sel : path) = TblSel [(sel,path2selector base path)] + + +------------------------------------------------------------ +-- updating the MCF rule + +readArgCType :: Int -> CnvMonad SLinType +readArgCType arg = do (_, _, _, ctypes) <- readState + return (ctypes !! arg) + +restrictArg :: Int -> SPath -> STerm -> CnvMonad () +restrictArg arg path term + = do (head, args, ctype, ctypes) <- readState + args' <- updateNthM (restrictFCat path term) arg args + writeState (head, args', ctype, ctypes) + +projectArg :: Int -> SPath -> CnvMonad () +projectArg arg path + = do (head, args, ctype, ctypes) <- readState + args' <- updateNthM (projectFCat path) arg args + writeState (head, args', ctype, ctypes) + +readHeadCType :: CnvMonad SLinType +readHeadCType = do (_, _, ctype, _) <- readState + return ctype + +restrictHead :: SPath -> STerm -> CnvMonad () +restrictHead path term + = do (head, args, ctype, ctypes) <- readState + head' <- restrictFCat path term head + writeState (head', args, ctype, ctypes) + +projectHead :: SPath -> CnvMonad () +projectHead path + = do (head, args, ctype, ctypes) <- readState + head' <- projectFCat path head + writeState (head', args, ctype, ctypes) + +restrictFCat :: SPath -> STerm -> FCat -> CnvMonad FCat +restrictFCat path0 term0 (FCat id cat rcs tcs) = do + tcs <- addConstraint tcs + return (FCat id cat rcs tcs) + where + addConstraint (c@(path,term) : cs) + | path0 > path = liftM (c:) (addConstraint cs) + | path0 == path = guard (term0 == term) >> + return (c : cs) + addConstraint cs = return ((path0,term0) : cs) + +projectFCat :: SPath -> FCat -> CnvMonad FCat +projectFCat path0 (FCat id cat rcs tcs) = do + return (FCat id cat (addConstraint rcs) tcs) + where + addConstraint (path : rcs) + | path0 > path = path : addConstraint rcs + | path0 == path = path : rcs + addConstraint rcs = path0 : rcs -- cgit v1.2.3