---------------------------------------------------------------------- -- | -- Maintainer : PL -- Stability : (stable) -- Portability : (portable) -- -- > CVS $Date: 2005/04/21 16:22:58 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.2 $ -- -- Converting SimpleGFC grammars to MCFG grammars, nondeterministically. -- -- the resulting grammars might be /very large/ -- -- the conversion is only equivalent if the GFC grammar has a context-free backbone. ----------------------------------------------------------------------------- module GF.OldParsing.ConvertSimpleToMCFG.Nondet (convertGrammar) where import GF.System.Tracing import GF.Printing.PrintParser import GF.Printing.PrintSimplifiedTerm -- import PrintGFC -- import qualified PrGrammar as PG import Control.Monad -- import Ident (Ident(..)) import qualified GF.Canon.AbsGFC as AbsGFC -- import GFC import GF.Canon.Look import GF.Data.Operations -- import qualified Modules as M import GF.Canon.CMacros (defLinType) -- import MkGFC (grammar2canon) import GF.OldParsing.Utilities -- import GF.OldParsing.GrammarTypes import GF.Data.SortedList import qualified GF.OldParsing.MCFGrammar as MCF (Grammar, Rule(..), Lin(..)) import GF.OldParsing.SimpleGFC -- import Maybe (listToMaybe) import Data.List (groupBy) -- , transpose) import GF.Data.BacktrackM ---------------------------------------------------------------------- --convertGrammar :: Grammar -> MCF.Grammar convertGrammar rules = tracePrt "#mcf-rules total" (prt . length) $ solutions conversion rules undefined where conversion = member rules >>= convertRule --convertRule :: Rule -> CnvMonad MCF.Rule convertRule (Rule fun (cat :@ _, decls) (Just (term, ctype))) = do let args = [ arg | _ ::: (arg :@ _) <- decls ] writeState (initialMCat cat, map initialMCat args, []) convertTerm cat term (newCat, newArgs, linRec) <- readState let newTerm = map (instLin newArgs) linRec return (MCF.Rule newCat newArgs newTerm fun) convertRule _ = failure instLin newArgs (MCF.Lin lbl lin) = MCF.Lin lbl (map instSym lin) where instSym = mapSymbol instCat id instCat (_, lbl, arg) = (newArgs !! arg, lbl, arg) --convertTerm :: Cat -> Term -> CnvMonad () convertTerm cat term = do rterm <- simplifyTerm term env <- readEnv let ctype = lookupCType env cat reduce ctype rterm emptyPath ------------------------------------------------------------ {- type CnvMonad a = BacktrackM Grammar CMRule a type CMRule = (MCFCat, [MCFCat], LinRec) type LinRec = [Lin Cat Path Tokn] -} --initialMCat :: Cat -> MCFCat initialMCat cat = (cat, []) --MCFCat cat [] ---------------------------------------------------------------------- --simplifyTerm :: Term -> CnvMonad STerm simplifyTerm (con :^ terms) = liftM (con :^) $ mapM simplifyTerm terms simplifyTerm (Rec record) = liftM Rec $ mapM simplifyAssign record simplifyTerm (term :. lbl) = liftM (+. lbl) $ simplifyTerm term simplifyTerm (Tbl table) = Tbl $ mapM simplifyCase table simplifyTerm (term :! sel) = do sterm <- simplifyTerm term ssel <- simplifyTerm sel case sterm of Tbl table -> do (pat, val) <- member table pat =?= ssel return val _ -> do sel' <- expandTerm ssel return (sterm +! sel') simplifyTerm (Variants terms) = liftM Variants $ mapM simplifyTerm terms simplifyTerm (term1 :++ term2) = liftM2 (:++) (simplifyTerm term1) (simplifyTerm term2) simplifyTerm term = return term -- error constructors: -- (I CIdent) - from resource -- (LI Ident) - pattern variable -- (EInt Integer) - integer --simplifyAssign :: Assign -> CnvMonad (Label, STerm) simplifyAssign (lbl, term) = liftM ((,) lbl) $ simplifyTerm term --simplifyCase :: Case -> [CnvMonad (STerm, STerm)] simplifyCase (pat, term) = liftM2 (,) (simplifyTerm pat) (simplifyTerm term) ------------------------------------------------------------ -- reducing simplified terms, collecting mcf rules --reduce :: CType -> STerm -> Path -> CnvMonad () reduce StrT term path = updateLin (path, term) reduce (ConT _) term path = do pat <- expandTerm term updateHead (path, pat) reduce ctype (Variants terms) path = do term <- member terms reduce ctype term path reduce (RecT rtype) term path = sequence_ [ reduce ctype (term +. lbl) (path ++. lbl) | (lbl, ctype) <- rtype ] reduce (TblT _ ctype) (Tbl table) path = sequence_ [ reduce ctype term (path ++! pat) | (pat, term) <- table ] reduce (TblT ptype vtype) arg@(Arg _ _ _) path = do env <- readEnv sequence_ [ reduce vtype (arg +! pat) (path ++! pat) | pat <- groundTerms ptype ] reduce ctype term path = error ("reduce:\n ctype = (" ++ show ctype ++ ")\n term = (" ++ show term ++ ")\n path = (" ++ show path ++ ")\n") ------------------------------------------------------------ -- expanding a term to ground terms --expandTerm :: STerm -> CnvMonad STerm expandTerm arg@(Arg _ _ _) = do env <- readEnv pat <- member $ groundTerms $ cTypeForArg env arg pat =?= arg return pat expandTerm (con :^ terms) = liftM (con :^) $ mapM expandTerm terms expandTerm (Rec record) = liftM Rec $ mapM expandAssign record expandTerm (Variants terms) = member terms >>= expandTerm expandTerm term = error $ "expandTerm: " ++ show term --expandAssign :: (Label, STerm) -> CnvMonad (Label, STerm) expandAssign (lbl, term) = liftM ((,) lbl) $ expandTerm term ------------------------------------------------------------ -- unification of patterns and selection terms --(=?=) :: STerm -> STerm -> CnvMonad () Wildcard =?= _ = return () Rec precord =?= arg@(Arg _ _ _) = sequence_ [ pat =?= (arg +. lbl) | (lbl, pat) <- precord ] pat =?= Arg arg _ path = updateArg arg (path, pat) (con :^ pats) =?= (con' :^ terms) = do guard (con==con' && length pats==length terms) sequence_ $ zipWith (=?=) pats terms Rec precord =?= Rec record = sequence_ [ maybe mzero (pat =?=) mterm | (lbl, pat) <- precord, let mterm = lookup lbl record ] pat =?= term = error $ "(=?=): " ++ show pat ++ " =?= " ++ show term ------------------------------------------------------------ -- updating the mcf rule --updateArg :: Int -> Constraint -> CnvMonad () updateArg arg cn = do (head, args, lins) <- readState args' <- updateNth (addToMCFCat cn) arg args writeState (head, args', lins) --updateHead :: Constraint -> CnvMonad () updateHead cn = do (head, args, lins) <- readState head' <- addToMCFCat cn head writeState (head', args, lins) --updateLin :: Constraint -> CnvMonad () updateLin (path, term) = do let newLins = term2lins term (head, args, lins) <- readState let lins' = lins ++ map (MCF.Lin path) newLins writeState (head, args, lins') --term2lins :: STerm -> [[Symbol (Cat, Path, Int) Tokn]] term2lins (Arg arg cat path) = return [Cat (cat, path, arg)] term2lins (Token str) = return [Tok str] term2lins (t1 :++ t2) = liftM2 (++) (term2lins t1) (term2lins t2) term2lins (Empty) = return [] term2lins (Variants terms) = terms >>= term2lins term2lins term = error $ "term2lins: " ++ show term --addToMCFCat :: Constraint -> MCFCat -> CnvMonad MCFCat addToMCFCat cn ({-MCFCat-} cat, cns) = liftM ({-MCFCat-} (,) cat) $ addConstraint cn cns --addConstraint :: Constraint -> [Constraint] -> CnvMonad [Constraint] addConstraint cn0 (cn : cns) | fst cn0 > fst cn = liftM (cn:) (addConstraint cn0 cns) | fst cn0 == fst cn = guard (snd cn0 == snd cn) >> return (cn : cns) addConstraint cn0 cns = return (cn0 : cns) ---------------------------------------------------------------------- -- utilities updateNth :: Monad m => (a -> m a) -> Int -> [a] -> m [a] updateNth update 0 (a : as) = liftM (:as) (update a) updateNth update n (a : as) = liftM (a:) (updateNth update (n-1) as) --lookupCType :: GrammarEnv -> Cat -> CType lookupCType env cat = errVal defLinType $ lookupLincat (fst env) (AbsGFC.CIQ (snd env) cat) --groundTerms :: GrammarEnv -> CType -> [STerm] groundTerms env ctype = err error (map term2spattern) $ allParamValues (fst env) ctype --cTypeForArg :: GrammarEnv -> STerm -> CType cTypeForArg env (Arg nr cat (Path path)) = follow path $ lookupCType env cat where follow [] ctype = ctype follow (Right pat : path) (TblT _ ctype) = follow path ctype follow (Left lbl : path) (RecT rec) = case [ ctype | (lbl', ctype) <- rec, lbl == lbl' ] of [ctype] -> follow path ctype err -> error $ "follow: " ++ show rec ++ " . " ++ show lbl ++ " results in " ++ show err term2spattern (AbsGFC.R rec) = Rec [ (lbl, term2spattern term) | AbsGFC.Ass lbl term <- rec ] term2spattern (AbsGFC.Con con terms) = con :^ map term2spattern terms