summaryrefslogtreecommitdiff
path: root/src/GF/OldParsing/ConvertFiniteSimple.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/OldParsing/ConvertFiniteSimple.hs')
-rw-r--r--src/GF/OldParsing/ConvertFiniteSimple.hs121
1 files changed, 0 insertions, 121 deletions
diff --git a/src/GF/OldParsing/ConvertFiniteSimple.hs b/src/GF/OldParsing/ConvertFiniteSimple.hs
deleted file mode 100644
index a05092550..000000000
--- a/src/GF/OldParsing/ConvertFiniteSimple.hs
+++ /dev/null
@@ -1,121 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer : PL
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:22:43 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.2 $
---
--- 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 GF.Data.Operations
-import GF.Infra.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 "" "" ""
-
-