forked from GitHub/gf-core
"Committed_by_peb"
This commit is contained in:
peb
257
src/GF/Parsing/ConvertFiniteGFC.hs
Normal file
257
src/GF/Parsing/ConvertFiniteGFC.hs
Normal file
@@ -0,0 +1,257 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/03/29 11:18:39 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.1 $
|
||||
--
|
||||
-- Calculating the finiteness of each type in a grammar
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Parsing.ConvertFiniteGFC where
|
||||
|
||||
import Operations
|
||||
import GFC
|
||||
import MkGFC
|
||||
import AbsGFC
|
||||
import Ident (Ident(..))
|
||||
import GF.System.Tracing
|
||||
import GF.Printing.PrintParser
|
||||
import GF.Printing.PrintSimplifiedTerm
|
||||
import GF.Data.SortedList
|
||||
import GF.Data.Assoc
|
||||
import GF.Data.BacktrackM
|
||||
|
||||
type Cat = Ident
|
||||
type Name = Ident
|
||||
|
||||
type CnvMonad a = BacktrackM () () a
|
||||
|
||||
convertGrammar :: CanonGrammar -> CanonGrammar
|
||||
convertGrammar = canon2grammar . convertCanon . grammar2canon
|
||||
|
||||
convertCanon :: Canon -> Canon
|
||||
convertCanon (Gr modules) = Gr (map (convertModule split) modules)
|
||||
where split = calcSplitable modules
|
||||
|
||||
convertModule :: Splitable -> Module -> Module
|
||||
convertModule split (Mod mtyp ext op fl defs)
|
||||
= Mod mtyp ext op fl newDefs
|
||||
where newDefs = solutions defMonad () ()
|
||||
defMonad = member defs >>= convertDef split
|
||||
|
||||
-- the main conversion function
|
||||
convertDef :: Splitable -> Def -> CnvMonad Def
|
||||
|
||||
convertDef split (AbsDCat cat decls cidents)
|
||||
= case splitableCat split cat of
|
||||
Just newCats -> do newCat <- member newCats
|
||||
return $ AbsDCat newCat decls cidents
|
||||
Nothing -> do (newCat, newDecls) <- expandDecls cat decls
|
||||
return $ AbsDCat newCat newDecls cidents
|
||||
where expandDecls cat [] = return (cat, [])
|
||||
expandDecls cat (decl@(Decl var typ) : decls)
|
||||
= do (newCat, newDecls) <- expandDecls cat decls
|
||||
let argCat = resultCat typ
|
||||
case splitableCat split argCat of
|
||||
Nothing -> return (newCat, decl : newDecls)
|
||||
Just newArgs -> do newArg <- member newArgs
|
||||
return (mergeCats "/" newCat newArg, newDecls)
|
||||
|
||||
convertDef split (AbsDFun fun typ@(EAtom (AC (CIQ mod cat))) def)
|
||||
= case splitableFun split fun of
|
||||
Just newCat -> return (AbsDFun fun (EAtom (AC (CIQ mod newCat))) def)
|
||||
Nothing -> do newTyp <- expandType split [] typ
|
||||
return (AbsDFun fun newTyp def)
|
||||
convertDef split (AbsDFun fun typ def)
|
||||
= do newTyp <- expandType split [] typ
|
||||
return (AbsDFun fun newTyp def)
|
||||
|
||||
convertDef _ def = return def
|
||||
|
||||
-- expanding Exp's
|
||||
expandType :: Splitable -> [(Ident, Cat)] -> Exp -> CnvMonad Exp
|
||||
expandType split env (EProd x a@(EAtom (AC (CIQ mod cat))) b)
|
||||
= case splitableCat split cat of
|
||||
Nothing -> do b' <- expandType split env b
|
||||
return (EProd x a b')
|
||||
Just newCats -> do newCat <- member newCats
|
||||
b' <- expandType split ((x,newCat):env) b
|
||||
return (EProd x (EAtom (AC (CIQ mod newCat))) b')
|
||||
expandType split env (EProd x a b)
|
||||
= do a' <- expandType split env a
|
||||
b' <- expandType split env b
|
||||
return (EProd x a' b')
|
||||
expandType split env app
|
||||
= expandApp split env [] app
|
||||
|
||||
expandApp :: Splitable -> [(Ident, Cat)] -> [Cat] -> Exp -> CnvMonad Exp
|
||||
expandApp split env addons (EAtom (AC (CIQ mod cat)))
|
||||
= return (EAtom (AC (CIQ mod (foldl (mergeCats "/") cat addons))))
|
||||
expandApp split env addons (EApp exp arg@(EAtom (AC (CIQ mod fun))))
|
||||
= case splitableFun split fun of
|
||||
Just newCat -> expandApp split env (newCat:addons) exp
|
||||
Nothing -> do exp' <- expandApp split env addons exp
|
||||
return (EApp exp' arg)
|
||||
expandApp split env addons (EApp exp arg@(EAtom (AV x)))
|
||||
= case lookup x env of
|
||||
Just newCat -> expandApp split env (newCat:addons) exp
|
||||
Nothing -> do exp' <- expandApp split env addons exp
|
||||
return (EApp exp' arg)
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- 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 :: [Module] -> Splitable
|
||||
calcSplitable modules = (listAssoc splitableCats, listAssoc splitableFuns)
|
||||
where splitableCats = tracePrt "splitableCats" (prtSep " ") $
|
||||
groupPairs $ nubsort
|
||||
[ (cat, mergeCats ":" fun cat) | (cat, fun) <- constantCats ]
|
||||
|
||||
splitableFuns = tracePrt "splitableFuns" (prtSep " ") $
|
||||
nubsort
|
||||
[ (fun, mergeCats ":" fun cat) | (cat, fun) <- constantCats ]
|
||||
|
||||
constantCats = tracePrt "constantCats" (prtSep " ") $
|
||||
[ (cat, fun) |
|
||||
AbsDFun fun (EAtom (AC (CIQ _ cat))) _ <- absDefs,
|
||||
dependentConstants ?= cat ]
|
||||
|
||||
dependentConstants = listSet $
|
||||
tracePrt "dep consts" prt $
|
||||
dependentCats <\\> funCats
|
||||
|
||||
funCats = tracePrt "fun cats" prt $
|
||||
nubsort [ resultCat typ |
|
||||
AbsDFun _ typ@(EProd _ _ _) _ <- absDefs ]
|
||||
|
||||
dependentCats = tracePrt "dep cats" prt $
|
||||
nubsort [ cat | AbsDCat _ decls _ <- absDefs,
|
||||
Decl _ (EAtom (AC (CIQ _ cat))) <- decls ]
|
||||
|
||||
absDefs = concat [ defs | Mod (MTAbs _) _ _ _ defs <- modules ]
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
resultCat :: Exp -> Cat
|
||||
resultCat (EProd _ _ b) = resultCat b
|
||||
resultCat (EApp a _) = resultCat a
|
||||
resultCat (EAtom (AC (CIQ _ cat))) = cat
|
||||
|
||||
mergeCats :: String -> Cat -> Cat -> Cat
|
||||
mergeCats str (IC cat) (IC arg) = IC (cat ++ str ++ arg)
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- obsolete?
|
||||
|
||||
{-
|
||||
type FiniteCats = Assoc Cat Integer
|
||||
|
||||
calculateFiniteness :: Canon -> FiniteCats
|
||||
calculateFiniteness canon@(Gr modules)
|
||||
= trace2 "#typeInfo" (prt tInfo) $
|
||||
finiteCats
|
||||
|
||||
where finiteCats = listAssoc [ (cat, fin) | (cat, Just fin) <- finiteInfo ]
|
||||
finiteInfo = map finInfo groups
|
||||
|
||||
finInfo :: (Cat, [[Cat]]) -> (Cat, Maybe Integer)
|
||||
finInfo (cat, ctxts)
|
||||
| cyclicCats ?= cat = (cat, Nothing)
|
||||
| otherwise = (cat, fmap (sum . map product) $
|
||||
sequence (map (sequence . map lookFinCat) ctxts))
|
||||
|
||||
lookFinCat :: Cat -> Maybe Integer
|
||||
lookFinCat cat = maybe (error "lookFinCat: Nothing") id $
|
||||
lookup cat finiteInfo
|
||||
|
||||
cyclicCats :: Set Cat
|
||||
cyclicCats = listSet $
|
||||
tracePrt "cyclic cats" prt $
|
||||
union $ map nubsort $ cyclesIn dependencies
|
||||
|
||||
dependencies :: [(Cat, [Cat])]
|
||||
dependencies = tracePrt "dependencies" (prtAfter "\n") $
|
||||
mapSnd (union . nubsort) groups
|
||||
|
||||
groups :: [(Cat, [[Cat]])]
|
||||
groups = tracePrt "groups" (prtAfter "\n") $
|
||||
mapSnd (map snd) $ groupPairs (nubsort allFuns)
|
||||
|
||||
allFuns = tracePrt "all funs" (prtAfter "\n") $
|
||||
[ (cat, (fun, ctxt)) |
|
||||
Mod (MTAbs _) _ _ _ defs <- modules,
|
||||
AbsDFun fun typ _ <- defs,
|
||||
let (cat, ctxt) = err error id $ typeForm typ ]
|
||||
|
||||
tInfo = calculateTypeInfo 30 finiteCats (splitDefs canon)
|
||||
|
||||
-- | stolen from 'Macros.qTypeForm', converted to GFC, and severely simplified
|
||||
typeForm :: Monad m => Exp -> m (Cat, [Cat])
|
||||
typeForm t = case t of
|
||||
EProd x a b -> do
|
||||
(cat, ctxt) <- typeForm b
|
||||
a' <- stripType a
|
||||
return (cat, a':ctxt)
|
||||
EApp c a -> do
|
||||
(cat, _) <- typeForm c
|
||||
return (cat, [])
|
||||
EAtom (AC (CIQ _ con)) ->
|
||||
return (con, [])
|
||||
_ ->
|
||||
fail $ "no normal form of type: " ++ prt t
|
||||
|
||||
stripType :: Monad m => Exp -> m Cat
|
||||
stripType (EApp c a) = stripType c
|
||||
stripType (EAtom (AC (CIQ _ con))) = return con
|
||||
stripType t = fail $ "can't strip type: " ++ prt t
|
||||
|
||||
mapSnd f xs = [ (a, f b) | (a, b) <- xs ]
|
||||
-}
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- obsolete?
|
||||
|
||||
{-
|
||||
type SplitDefs = ([Def], [Def], [Def], [Def])
|
||||
----- AbsDCat AbsDFun CncDCat CncDFun
|
||||
|
||||
splitDefs :: Canon -> SplitDefs
|
||||
splitDefs (Gr modules) = foldr splitDef ([], [], [], []) $
|
||||
concat [ defs | Mod _ _ _ _ defs <- modules ]
|
||||
|
||||
splitDef :: Def -> SplitDefs -> SplitDefs
|
||||
splitDef ac@(AbsDCat _ _ _) (acs, afs, ccs, cfs) = (ac:acs, afs, ccs, cfs)
|
||||
splitDef af@(AbsDFun _ _ _) (acs, afs, ccs, cfs) = (acs, af:afs, ccs, cfs)
|
||||
splitDef cc@(CncDCat _ _ _ _) (acs, afs, ccs, cfs) = (acs, afs, cc:ccs, cfs)
|
||||
splitDef cf@(CncDFun _ _ _ _ _) (acs, afs, ccs, cfs) = (acs, afs, ccs, cf:cfs)
|
||||
splitDef _ sd = sd
|
||||
|
||||
--calculateTypeInfo :: Integer -> FiniteCats -> SplitDefs -> ?
|
||||
calculateTypeInfo maxFin allFinCats (acs, afs, ccs, cfs)
|
||||
= (depCatsToExpand, catsToSplit)
|
||||
where absDefsToExpand = tracePrt "absDefsToExpand" prt $
|
||||
[ ((cat, fin), cats) |
|
||||
AbsDCat cat args _ <- acs,
|
||||
not (null args),
|
||||
cats <- mapM catOfDecl args,
|
||||
fin <- lookupAssoc allFinCats cat,
|
||||
fin <= maxFin
|
||||
]
|
||||
(depCatsToExpand, argsCats') = unzip absDefsToExpand
|
||||
catsToSplit = union (map nubsort argsCats')
|
||||
catOfDecl (Decl _ exp) = err fail return $ stripType exp
|
||||
-}
|
||||
Reference in New Issue
Block a user