mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-17 08:49:31 -06:00
122 lines
4.0 KiB
Haskell
122 lines
4.0 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- 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 "" "" ""
|
|
|
|
|