From 6ce60d64a9c3552a999b99fd6a4edd3109f4215b Mon Sep 17 00:00:00 2001 From: aarne Date: Fri, 21 Sep 2007 09:15:14 +0000 Subject: [PATCH] gfcc generation in gfc works for some grammars --- src/GF/Devel/GFC.hs | 9 +- src/GF/Devel/GrammarToGFCC.hs | 38 ++++++--- src/GF/Devel/ModDeps.hs | 153 ++++++++++++++++++++++++++++++++++ 3 files changed, 184 insertions(+), 16 deletions(-) create mode 100644 src/GF/Devel/ModDeps.hs diff --git a/src/GF/Devel/GFC.hs b/src/GF/Devel/GFC.hs index eba212486..ba2759c87 100644 --- a/src/GF/Devel/GFC.hs +++ b/src/GF/Devel/GFC.hs @@ -2,6 +2,7 @@ module Main where import GF.Devel.Compile import GF.Devel.GrammarToGFCC +import GF.Devel.UseIO ---import GF.Devel.PrGrammar --- import System @@ -13,9 +14,11 @@ main = do "-help":[] -> putStrLn "usage: gfc (--make) FILES" "--make":fs -> do gr <- batchCompile fs - --- putStrLn $ prGrammar gr - writeFile "a.gfcc" $ prGrammar2gfcc gr - putStrLn "Wrote file a.gfcc." + let name = justModuleName (last fs) + let (abs,gc) = prGrammar2gfcc name gr + let target = abs ++ ".gfcc" + writeFile target gc + putStrLn $ "wrote file " ++ target _ -> do mapM_ batchCompile (map return xx) putStrLn "Done." diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs index cbe8af891..c8edd0647 100644 --- a/src/GF/Devel/GrammarToGFCC.hs +++ b/src/GF/Devel/GrammarToGFCC.hs @@ -10,6 +10,7 @@ import qualified GF.Grammar.Macros as GM import qualified GF.Infra.Modules as M import qualified GF.Infra.Option as O +import GF.Devel.ModDeps import GF.Infra.Ident import GF.Data.Operations import GF.Text.UTF8 @@ -20,11 +21,15 @@ import Debug.Trace ---- -- the main function: generate GFCC from GF. -prGrammar2gfcc :: SourceGrammar-> String -prGrammar2gfcc = Pr.printTree . mkCanon2gfcc +prGrammar2gfcc :: String -> SourceGrammar -> (String,String) +prGrammar2gfcc cnc gr = (abs, Pr.printTree gc) where + (abs,gc) = mkCanon2gfcc cnc gr -mkCanon2gfcc :: SourceGrammar -> C.Grammar -mkCanon2gfcc = canon2gfcc . reorder . utf8Conv . canon2canon +mkCanon2gfcc :: String -> SourceGrammar -> (String,C.Grammar) +mkCanon2gfcc cnc gr = + (prIdent abs, (canon2gfcc . reorder abs . utf8Conv . canon2canon abs) gr) + where + abs = err error id $ M.abstractOfConcrete gr (identC cnc) -- This is needed to reorganize the grammar. GFCC has its own back-end optimization. -- But we need to have the canonical order in tables, created by valOpt @@ -102,15 +107,14 @@ mkTerm tr = case tr of -- return just one module per language -reorder :: SourceGrammar -> SourceGrammar -reorder cg = M.MGrammar $ +reorder :: Ident -> SourceGrammar -> SourceGrammar +reorder abs cg = M.MGrammar $ (abs, M.ModMod $ M.Module M.MTAbstract M.MSComplete [] [] [] adefs): [(c, M.ModMod $ M.Module (M.MTConcrete abs) M.MSComplete [] [] [] (sorted2tree js)) | (c,js) <- cncs] where - abs = maybe (error "no abstract") id $ M.greatestAbstract cg mos = M.allModMod cg adefs = sorted2tree $ sortBy (\ (f,_) (g,_) -> compare f g) @@ -125,9 +129,8 @@ reorder cg = M.MGrammar $ finfo <- tree2list (M.jments mo)] -- one grammar per language - needed for symtab generation -repartition :: SourceGrammar -> [SourceGrammar] -repartition cg = [M.partOfGrammar cg (lang,mo) | - let abs = maybe (error "no abstract") id $ M.greatestAbstract cg, +repartition :: Ident -> SourceGrammar -> [SourceGrammar] +repartition abs cg = [M.partOfGrammar cg (lang,mo) | let mos = M.allModMod cg, lang <- M.allConcretes cg abs, let mo = errVal @@ -151,11 +154,11 @@ utf8Conv = M.MGrammar . map toUTF8 . M.modules where -- translate tables and records to arrays, parameters and labels to indices -canon2canon :: SourceGrammar -> SourceGrammar -canon2canon = recollect . map cl2cl . repartition where +canon2canon :: Ident -> SourceGrammar -> SourceGrammar +canon2canon abs = recollect . map cl2cl . repartition abs . purgeGrammar abs where recollect = M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules - cl2cl cg = tr $ M.MGrammar $ map c2c $ M.modules cg where + cl2cl cg = M.MGrammar $ map c2c $ M.modules cg where c2c (c,m) = case m of M.ModMod mo@(M.Module _ _ _ _ _ js) -> (c, M.ModMod $ M.replaceJudgements mo $ mapTree j2j js) @@ -175,6 +178,15 @@ canon2canon = recollect . map cl2cl . repartition where (unlines [A.prt t | (t,_) <- Map.toList typs]) + +purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar +purgeGrammar abstr gr = (M.MGrammar . filter complete . purge . M.modules) gr where + purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst) + needed = nub $ concatMap (requiredCanModules isSingle gr) acncs + acncs = abstr : M.allConcretes gr abstr + isSingle = True + complete (i,M.ModMod m) = M.isCompleteModule m --- not . isIncompleteCanon + type ParamEnv = (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels Map.Map Term Integer, -- untyped terms to values diff --git a/src/GF/Devel/ModDeps.hs b/src/GF/Devel/ModDeps.hs new file mode 100644 index 000000000..ec5702910 --- /dev/null +++ b/src/GF/Devel/ModDeps.hs @@ -0,0 +1,153 @@ +---------------------------------------------------------------------- +-- | +-- Module : ModDeps +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/11 23:24:34 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.14 $ +-- +-- Check correctness of module dependencies. Incomplete. +-- +-- AR 13\/5\/2003 +----------------------------------------------------------------------------- + +module GF.Devel.ModDeps (mkSourceGrammar, + moduleDeps, + openInterfaces, + requiredCanModules + ) where + +import GF.Grammar.Grammar +import GF.Infra.Ident +import GF.Infra.Option +import GF.Devel.PrGrammar +import GF.Compile.Update +import GF.Grammar.Lookup +import GF.Infra.Modules + +import GF.Data.Operations + +import Control.Monad +import Data.List + +-- | to check uniqueness of module names and import names, the +-- appropriateness of import and extend types, +-- to build a dependency graph of modules, and to sort them topologically +mkSourceGrammar :: [(Ident,SourceModInfo)] -> Err SourceGrammar +mkSourceGrammar ms = do + let ns = map fst ms + checkUniqueErr ns + mapM (checkUniqueImportNames ns . snd) ms + deps <- moduleDeps ms + deplist <- either + return + (\ms -> Bad $ "circular modules" +++ unwords (map show ms)) $ + topoTest deps + return $ MGrammar [(m, maybe undefined id $ lookup m ms) | IdentM m _ <- deplist] + +checkUniqueErr :: (Show i, Eq i) => [i] -> Err () +checkUniqueErr ms = do + let msg = checkUnique ms + if null msg then return () else Bad $ unlines msg + +-- | check that import names don't clash with module names +checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err () +checkUniqueImportNames ns mo = case mo of + ModMod m -> test [n | OQualif _ n v <- opens m, n /= v] + _ -> return () --- Bad $ "bug: ModDeps does not treat" +++ show mo + where + + test ms = testErr (all (`notElem` ns) ms) + ("import names clashing with module names among" +++ + unwords (map prt ms)) + +type Dependencies = [(IdentM Ident,[IdentM Ident])] + +-- | to decide what modules immediately depend on what, and check if the +-- dependencies are appropriate +moduleDeps :: [(Ident,SourceModInfo)] -> Err Dependencies +moduleDeps ms = mapM deps ms where + deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of + ModMod m -> case mtype m of + MTConcrete a -> do + aty <- lookupModuleType gr a + testErr (aty == MTAbstract) "the of-module is not an abstract syntax" + chDep (IdentM c (MTConcrete a)) + (extends m) (MTConcrete a) (opens m) MTResource + t -> chDep (IdentM c t) (extends m) t (opens m) t + + chDep it es ety os oty = do + ests <- mapM (lookupModuleType gr) es + testErr (all (compatMType ety) ests) "inappropriate extension module type" +---- osts <- mapM (lookupModuleType gr . openedModule) os +---- testErr (all (compatOType oty) osts) "inappropriate open module type" + let ab = case it of + IdentM _ (MTConcrete a) -> [IdentM a MTAbstract] + _ -> [] ---- + return (it, ab ++ + [IdentM e ety | e <- es] ++ + [IdentM (openedModule o) oty | o <- os]) + + -- check for superficial compatibility, not submodule relation etc: what can be extended + compatMType mt0 mt = case (mt0,mt) of + (MTResource, MTConcrete _) -> True + (MTInstance _, MTConcrete _) -> True + (MTInterface, MTAbstract) -> True + (MTConcrete _, MTConcrete _) -> True + (MTInstance _, MTInstance _) -> True + (MTReuse _, MTReuse _) -> True + (MTInstance _, MTResource) -> True + (MTResource, MTInstance _) -> True + ---- some more? + _ -> mt0 == mt + -- in the same way; this defines what can be opened + compatOType mt0 mt = case mt0 of + MTAbstract -> mt == MTAbstract + MTTransfer _ _ -> mt == MTAbstract + _ -> case mt of + MTResource -> True + MTReuse _ -> True + MTInterface -> True + MTInstance _ -> True + _ -> False + + gr = MGrammar ms --- hack + +openInterfaces :: Dependencies -> Ident -> Err [Ident] +openInterfaces ds m = do + let deps = [(i,ds) | (IdentM i _,ds) <- ds] + let more (c,_) = [(i,mt) | Just is <- [lookup c deps], IdentM i mt <- is] + let mods = iterFix (concatMap more) (more (m,undefined)) + return $ [i | (i,MTInterface) <- mods] + +-- | this function finds out what modules are really needed in the canonical gr. +-- its argument is typically a concrete module name +requiredCanModules :: (Ord i, Show i) => Bool -> MGrammar i f a -> i -> [i] +requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where + exts = allExtends gr c + ops = if isSingle + then map fst (modules gr) + else iterFix (concatMap more) $ exts + more i = errVal [] $ do + m <- lookupModMod gr i + return $ extends m ++ [o | o <- map openedModule (opens m)] + notReuse i = errVal True $ do + m <- lookupModMod gr i + return $ isModRes m -- to exclude reused Cnc and Abs from required + + +{- +-- to test +exampleDeps = [ + (ir "Nat",[ii "Gen", ir "Adj"]), + (ir "Adj",[ii "Num", ii "Gen", ir "Nou"]), + (ir "Nou",[ii "Cas"]) + ] + +ii s = IdentM (IC s) MTInterface +ir s = IdentM (IC s) MTResource +-} +