diff options
Diffstat (limited to 'src-3.0/GF/Conversion/SimpleToFinite.hs')
| -rw-r--r-- | src-3.0/GF/Conversion/SimpleToFinite.hs | 178 |
1 files changed, 178 insertions, 0 deletions
diff --git a/src-3.0/GF/Conversion/SimpleToFinite.hs b/src-3.0/GF/Conversion/SimpleToFinite.hs new file mode 100644 index 000000000..bbd3ae355 --- /dev/null +++ b/src-3.0/GF/Conversion/SimpleToFinite.hs @@ -0,0 +1,178 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/01 09:53:19 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.7 $ +-- +-- Calculating the finiteness of each type in a grammar +----------------------------------------------------------------------------- + +module GF.Conversion.SimpleToFinite + (convertGrammar) where + +import GF.System.Tracing +import GF.Infra.Print + +import GF.Formalism.GCFG +import GF.Formalism.SimpleGFC +import GF.Formalism.Utilities +import GF.Conversion.Types + +import GF.Data.SortedList +import GF.Data.Assoc +import GF.Data.BacktrackM +import GF.Data.Utilities (lookupList) + +import GF.Infra.Ident (Ident(..)) + +type CnvMonad a = BacktrackM () a + +convertGrammar :: SGrammar -> SGrammar +convertGrammar rules = tracePrt "SimpleToFinie - nr. 'finite' rules" (prt . length) $ + solutions cnvMonad () + where split = calcSplitable rules + cnvMonad = member rules >>= convertRule split + +convertRule :: Splitable -> SRule -> CnvMonad SRule +convertRule split (Rule abs cnc) + = do newAbs <- convertAbstract split abs + return $ Rule newAbs cnc + +{- +-- old code +convertAbstract :: Splitable -> Abstract SDecl Name + -> CnvMonad (Abstract SDecl Name) +convertAbstract split (Abs decl decls name) + = case splitableFun split (name2fun name) of + Just cat' -> return $ Abs (Decl anyVar (mergeFun (name2fun name) cat') []) decls name + Nothing -> expandTyping split name [] decl decls [] + + +expandTyping :: Splitable -> Name -> [(Var, SCat)] -> SDecl -> [SDecl] -> [SDecl] + -> CnvMonad (Abstract SDecl Name) +expandTyping split name env (Decl x cat args) [] decls + = return $ Abs decl (reverse decls) name + where decl = substArgs split x env cat args [] +expandTyping split name env typ (Decl x xcat xargs : declsToDo) declsDone + = do (x', xcat', env') <- calcNewEnv + let decl = substArgs split x' env xcat' xargs [] + expandTyping split name env' typ declsToDo (decl : declsDone) + where calcNewEnv = case splitableCat split xcat of + Just newFuns -> do newFun <- member newFuns + let newCat = mergeFun newFun xcat + -- Just newCats -> do newCat <- member newCats + return (anyVar, newCat, (x,newCat) : env) + Nothing -> return (x, xcat, env) +-} + +-- new code +convertAbstract :: Splitable -> Abstract SDecl Name + -> CnvMonad (Abstract SDecl Name) +convertAbstract split (Abs decl decls name) + = case splitableFun split fun of + Just cat' -> return $ Abs (Decl anyVar ([] ::--> (mergeFun fun cat' ::@ []))) decls name + Nothing -> expandTyping split [] fun profiles [] decl decls [] + where Name fun profiles = name + +expandTyping :: Splitable -> [(Var, SCat)] + -> Fun -> [Profile (SyntaxForest Fun)] -> [Profile (SyntaxForest Fun)] + -> SDecl -> [SDecl] -> [SDecl] + -> CnvMonad (Abstract SDecl Name) +expandTyping split env fun [] profiles (Decl x (typargs ::--> (cat ::@ args))) [] decls + = return $ Abs decl (reverse decls) (Name fun (reverse profiles)) + where decl = substArgs split x env typargs cat args [] +expandTyping split env fun (prof:profiles) profsDone typ + (Decl x (xtypargs ::--> (xcat ::@ xargs)) : declsToDo) declsDone + = do (x', xcat', env', prof') <- calcNewEnv + let decl = substArgs split x' env xtypargs xcat' xargs [] + expandTyping split env' fun profiles (prof' : profsDone) typ declsToDo (decl : declsDone) + where calcNewEnv = case splitableCat split xcat of + Nothing -> return (x, xcat, env, prof) + Just newFuns -> do newFun <- member newFuns + let newCat = mergeFun newFun xcat + newProf = Constant (FNode newFun [[]]) + -- should really be using some kind of + -- "profile unification" + return (anyVar, newCat, (x,newCat) : env, newProf) + +substArgs :: Splitable -> Var -> [(Var, SCat)] -> [FOType SCat] + -> SCat -> [TTerm] -> [TTerm] -> SDecl +substArgs split x env typargs cat [] args = Decl x (typargs ::--> (cat ::@ reverse args)) +substArgs split x env typargs cat (arg:argsToDo) argsDone + = case argLookup split env arg of + Just newCat -> substArgs split x env typargs (mergeArg cat newCat) argsToDo argsDone + Nothing -> substArgs split x env typargs cat argsToDo (arg : argsDone) + +argLookup split env (TVar x) = lookup x env +argLookup split env (con :@ _) = fmap (mergeFun fun) (splitableFun split fun) + where fun = constr2fun con + + +---------------------------------------------------------------------- +-- splitable categories (finite, no dependencies) +-- they should also be used as some dependency + +type Splitable = (Assoc SCat [Fun], Assoc Fun SCat) + +splitableCat :: Splitable -> SCat -> Maybe [Fun] +splitableCat = lookupAssoc . fst + +splitableFun :: Splitable -> Fun -> Maybe SCat +splitableFun = lookupAssoc . snd + +calcSplitable :: [SRule] -> Splitable +calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat) + where splitableCat2Funs = groupPairs $ nubsort splitableCatFuns + + splitableFun2Cat = nubsort + [ (fun, cat) | (cat, fun) <- splitableCatFuns ] + + -- cat-fun pairs that are splitable + splitableCatFuns = tracePrt "SimpleToFinite - splitable functions" prt $ + [ (cat, name2fun name) | + Rule (Abs (Decl _ ([] ::--> (cat ::@ []))) [] name) _ <- rules, + splitableCats ?= cat ] + + -- all cats that are splitable + splitableCats = listSet $ + tracePrt "SimpleToFinite - finite categories to split" prt $ + (nondepCats <**> depCats) <\\> resultCats + + -- all result cats for some pure function + resultCats = tracePrt "SimpleToFinite - result cats" prt $ + nubsort [ cat | Rule (Abs (Decl _ (_ ::--> (cat ::@ _))) decls _) _ <- rules, + not (null decls) ] + + -- all cats in constants without dependencies + nondepCats = tracePrt "SimpleToFinite - nondep cats" prt $ + nubsort [ cat | Rule (Abs (Decl _ ([] ::--> (cat ::@ []))) [] _) _ <- rules ] + + -- all cats occurring as some dependency of another cat + depCats = tracePrt "SimpleToFinite - dep cats" prt $ + nubsort [ cat | Rule (Abs decl decls _) _ <- rules, + cat <- varCats [] (decls ++ [decl]) ] + + varCats _ [] = [] + varCats env (Decl x (xargs ::--> xtyp@(xcat ::@ _)) : decls) + = varCats ((x,xcat) : env) decls ++ + [ cat | (_::@args) <- (xtyp:xargs), arg <- args, + y <- varsInTTerm arg, cat <- lookupList y env ] + + +---------------------------------------------------------------------- +-- utilities +-- mergeing categories + +mergeCats :: String -> String -> String -> SCat -> SCat -> SCat +mergeCats before middle after (IC cat) (IC arg) + = IC (before ++ cat ++ middle ++ arg ++ after) + +mergeFun, mergeArg :: SCat -> SCat -> SCat +mergeFun = mergeCats "{" ":" "}" +mergeArg = mergeCats "" "" "" + + |