mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
179 lines
7.0 KiB
Haskell
179 lines
7.0 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- 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 "" "" ""
|
|
|
|
|