"Committed_by_peb"

src/GF/OldParsing/ConvertFiniteSimple.hs

@@ -0,0 +1,121 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:52 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Calculating the finiteness of each type in a grammar
+-----------------------------------------------------------------------------
+
+module GF.OldParsing.ConvertFiniteSimple 
+    (convertGrammar) where
+
+import GF.System.Tracing
+import GF.Printing.PrintParser
+import GF.Printing.PrintSimplifiedTerm
+
+import Operations
+import Ident (Ident(..))
+import GF.OldParsing.SimpleGFC
+import GF.Data.SortedList
+import GF.Data.Assoc
+import GF.Data.BacktrackM
+
+type CnvMonad a = BacktrackM () a
+
+convertGrammar :: Grammar -> Grammar
+convertGrammar rules = solutions cnvMonad () 
+    where split = calcSplitable rules
+	  cnvMonad = member rules >>= convertRule split
+
+convertRule :: Splitable -> Rule -> CnvMonad Rule
+convertRule split (Rule name typing term) 
+    = do newTyping <- convertTyping split name typing
+	 return $ Rule name newTyping term
+
+convertTyping :: Splitable -> Name -> Typing -> CnvMonad Typing
+convertTyping split name (typ, decls)
+    = case splitableFun split name of
+        Just newCat -> return (newCat :@ [], decls)
+	Nothing -> expandTyping split [] typ decls []
+
+
+expandTyping :: Splitable -> [(Var, Cat)] -> Type -> [Decl] -> [Decl] -> CnvMonad Typing
+expandTyping split env (cat :@ atoms) [] decls 
+    = return (substAtoms split env cat atoms [], reverse decls)
+expandTyping split env typ ((x ::: (xcat :@ xatoms)) : declsToDo) declsDone
+    = do env' <- calcNewEnv
+         expandTyping split env' typ declsToDo (decl : declsDone)
+    where decl = x ::: substAtoms split env xcat xatoms []
+	  calcNewEnv = case splitableCat split xcat of
+		         Just newCats -> do newCat <- member newCats
+					    return ((x,newCat) : env)
+			 Nothing -> return env
+
+substAtoms :: Splitable -> [(Var, Cat)] -> Cat -> [Atom] -> [Atom] -> Type
+substAtoms split env cat [] atoms = cat :@ reverse atoms
+substAtoms split env cat (atom:atomsToDo) atomsDone
+    = case atomLookup split env atom of
+        Just newCat -> substAtoms split env (mergeArg cat newCat) atomsToDo atomsDone
+	Nothing -> substAtoms split env cat atomsToDo (atom : atomsDone)
+
+atomLookup split env (AVar x) = lookup x env 
+atomLookup split env (ACon con) = splitableFun split (constr2name con)
+      
+
+----------------------------------------------------------------------
+-- splitable categories (finite, no dependencies)
+-- they should also be used as some dependency
+
+type Splitable = (Assoc Cat [Cat], Assoc Name Cat)
+
+splitableCat :: Splitable -> Cat -> Maybe [Cat]
+splitableCat = lookupAssoc . fst 
+
+splitableFun :: Splitable -> Name -> Maybe Cat
+splitableFun = lookupAssoc . snd
+
+calcSplitable :: [Rule] -> Splitable
+calcSplitable rules = (listAssoc splitableCats, listAssoc splitableFuns)
+    where splitableCats = tracePrt "splitableCats" (prtSep " ") $
+			  groupPairs $ nubsort 
+			  [ (cat, mergeFun fun cat) | (cat, fun) <- constantCats ]
+
+	  splitableFuns = tracePrt "splitableFuns" (prtSep " ") $
+			  nubsort
+			  [ (fun, mergeFun fun cat) | (cat, fun) <- constantCats ]
+
+	  constantCats = tracePrt "constantCats" (prtSep " ") $
+			 [ (cat, fun) |
+			   Rule fun (cat :@ [], []) _ <- rules,
+			   dependentConstants ?= cat ]
+
+          dependentConstants = listSet $
+			       tracePrt "dep consts" prt $
+			       dependentCats <\\> funCats
+
+	  funCats = tracePrt "fun cats" prt $
+		    nubsort [ cat | Rule _ (cat :@ _, decls) _ <- rules,
+			      not (null decls) ]
+
+          dependentCats = tracePrt "dep cats" prt $
+			  nubsort [ cat | Rule _ (cat :@ [], []) _ <- rules ]
+
+
+----------------------------------------------------------------------
+-- utilities
+
+-- mergeing categories
+mergeCats :: String -> String -> String -> Cat -> Cat -> Cat
+mergeCats before middle after (IC cat) (IC arg) 
+    = IC (before ++ cat ++ middle ++ arg ++ after)
+
+mergeFun, mergeArg :: Cat -> Cat -> Cat
+mergeFun = mergeCats "{" ":" "}"
+mergeArg = mergeCats "" "" ""
+
+