From 3b4ee92cbece3aff0243f0dfd0f41121808d8e8c Mon Sep 17 00:00:00 2001 From: aarne Date: Fri, 28 Sep 2007 13:42:50 +0000 Subject: [PATCH] started CheckGFCC --- src/GF/Canon/GFCC/CheckGFCC.hs | 81 ++++++++++++++++++++++++++++++++++ src/GF/Canon/GFCC/DataGFCC.hs | 1 - src/GF/Canon/GFCC/Shell.hs | 2 +- src/GF/Devel/Compile.hs | 26 ++++++++--- src/GF/Devel/GFC.hs | 16 ++++++- src/GF/Devel/GrammarToGFCC.hs | 2 +- 6 files changed, 118 insertions(+), 10 deletions(-) create mode 100644 src/GF/Canon/GFCC/CheckGFCC.hs diff --git a/src/GF/Canon/GFCC/CheckGFCC.hs b/src/GF/Canon/GFCC/CheckGFCC.hs new file mode 100644 index 000000000..cc27f5c1e --- /dev/null +++ b/src/GF/Canon/GFCC/CheckGFCC.hs @@ -0,0 +1,81 @@ +module GF.Canon.GFCC.CheckGFCC where + +import GF.Canon.GFCC.DataGFCC +import GF.Canon.GFCC.AbsGFCC +import GF.Canon.GFCC.PrintGFCC + +import qualified Data.Map as Map +import Control.Monad + +andMapM :: Monad m => (a -> m Bool) -> [a] -> m Bool +andMapM f xs = mapM f xs >>= return . and + +labelBoolIO :: String -> IO Bool -> IO Bool +labelBoolIO msg iob = do + b <- iob + if b then return b else (putStrLn msg >> return b) + +checkGFCC :: GFCC -> IO Bool +checkGFCC gfcc = andMapM (checkConcrete gfcc) $ Map.assocs $ concretes gfcc + +checkConcrete :: GFCC -> (CId,Map.Map CId Term) -> IO Bool +checkConcrete gfcc (lang,cnc) = + labelBoolIO (printTree lang) $ andMapM (checkLin gfcc lang) $ linRules cnc + +checkLin :: GFCC -> CId -> (CId,Term) -> IO Bool +checkLin gfcc lang (f,t) = + labelBoolIO (printTree f) $ checkTerm (lintype gfcc lang f) $ inline gfcc lang t + +checkTerm :: LinType -> Term -> IO Bool +checkTerm (args,val) trm = case (val,trm) of + (R tys, R trs) -> do + let (ntys,ntrs) = (length tys,length trs) + b <- checkCond + ("number of fields in " ++ prtrm ++ " does not match " ++ prval) (ntys == ntrs) + bs <- andMapM (uncurry check) (zip tys trs) + return $ b && bs + (R _, W _ r) -> check val r + _ -> return True + where + checkCond msg cond = if cond then return True else (putStrLn msg >> return False) + check ty tr = checkTerm (args,ty) tr + prtrm = printTree trm + prval = printTree val + +-- should be in a generic module, but not in the run-time DataGFCC + +type LinType = ([Term],Term) + +lintype :: GFCC -> CId -> CId -> LinType +lintype gfcc lang fun = case lookType gfcc fun of + Typ cs c -> (map linc cs, linc c) + where + linc = lookLincat gfcc lang + +lookLincat :: GFCC -> CId -> CId -> Term +lookLincat gfcc lang (CId cat) = lookLin gfcc lang (CId ("__" ++ cat)) + +linRules :: Map.Map CId Term -> [(CId,Term)] +linRules cnc = [(f,t) | (f@(CId (c:_)),t) <- Map.assocs cnc, c /= '_'] ---- + +inline :: GFCC -> CId -> Term -> Term +inline gfcc lang t = case t of + F c -> inl $ look c + _ -> composSafeOp inl t + where + inl = inline gfcc lang + look = lookLin gfcc lang + +composOp :: Monad m => (Term -> m Term) -> Term -> m Term +composOp f trm = case trm of + R ts -> liftM R $ mapM comp ts + S ts -> liftM S $ mapM comp ts + FV ts -> liftM FV $ mapM comp ts + P t u -> liftM2 P (comp t) (comp u) + W s t -> liftM (W s) $ comp t + _ -> return trm + where + comp = composOp f + +composSafeOp :: (Term -> Term) -> Term -> Term +composSafeOp f = maybe undefined id . composOp (return . f) diff --git a/src/GF/Canon/GFCC/DataGFCC.hs b/src/GF/Canon/GFCC/DataGFCC.hs index eabd8b3a3..f42b48d1b 100644 --- a/src/GF/Canon/GFCC/DataGFCC.hs +++ b/src/GF/Canon/GFCC/DataGFCC.hs @@ -131,4 +131,3 @@ mkGFCC (Grm (Hdr a cs) ab@(Abs funs) ccs) = GFCC { where mkCnc lins = fromList [(fun,lin) | Lin fun lin <- lins] ---- Asc - diff --git a/src/GF/Canon/GFCC/Shell.hs b/src/GF/Canon/GFCC/Shell.hs index 5285b89a8..5a2171a03 100644 --- a/src/GF/Canon/GFCC/Shell.hs +++ b/src/GF/Canon/GFCC/Shell.hs @@ -41,7 +41,7 @@ commands = unlines [ treat :: MultiGrammar -> String -> IO () treat mgr s = case words s of "gt" :cat:n:_ -> mapM_ prlinonly $ take (read1 n) $ generateAll mgr cat - "gtt":cat:n:_ -> mapM_ prlin $ generateAll mgr cat + "gtt":cat:n:_ -> mapM_ prlin $ take (read1 n) $ generateAll mgr cat "gr" :cat:n:_ -> generateRandom mgr cat >>= mapM_ prlinonly . take (read1 n) "grt":cat:n:_ -> generateRandom mgr cat >>= mapM_ prlin . take (read1 n) "p":lang:cat:ws -> do diff --git a/src/GF/Devel/Compile.hs b/src/GF/Devel/Compile.hs index a89ed4624..2e9de8a16 100644 --- a/src/GF/Devel/Compile.hs +++ b/src/GF/Devel/Compile.hs @@ -35,6 +35,16 @@ batchCompile opts files = do Ok (_,gr) <- appIOE $ foldM (compileModule defOpts) emptyCompileEnv files return gr +-- to output an intermediate stage +intermOut :: Options -> Option -> String -> IOE () +intermOut opts opt s = if oElem opt opts then + ioeIO (putStrLn ("\n\n--#" +++ prOpt opt) >> putStrLn s) + else return () + +prMod :: SourceModule -> String +prMod = compactPrint . prModule + + -- | environment variable for grammar search path gfGrammarPathVar = "GF_GRAMMAR_PATH" @@ -45,6 +55,7 @@ type CompileEnv = (Int,SourceGrammar) -- command-line options override options (marked by --#) in the file -- As for path: if it is read from file, the file path is prepended to each name. -- If from command line, it is used as it is. + compileModule :: Options -> CompileEnv -> FilePath -> IOE CompileEnv compileModule opts1 env file = do opts0 <- ioeIO $ getOptionsFromFile file @@ -60,21 +71,20 @@ compileModule opts1 env file = do ps <- ioeIO $ extendPathEnv gfLibraryPath gfGrammarPathVar ps1 let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ())) ioeIOIf $ putStrLn $ "module search path:" +++ show ps ---- - let st = env + let sgr = snd env let rfs = [] ---- files already in memory and their read times let file' = if useFileOpt then justFileName file else file -- to find file itself files <- getAllFiles opts ps rfs file' ioeIOIf $ putStrLn $ "files to read:" +++ show files ---- let names = map justModuleName files ioeIOIf $ putStrLn $ "modules to include:" +++ show names ---- - let env0 = compileEnvShSt st names + let sgr2 = MGrammar [m | m@(i,_) <- modules sgr, + notElem (prt i) $ map fileBody names] + let env0 = (0,sgr2) (e,mm) <- foldIOE (compileOne opts) env0 files maybe (return ()) putStrLnE mm return e -compileEnvShSt :: CompileEnv -> [ModName] -> CompileEnv -compileEnvShSt env@(_,sgr) fs = (0,sgr2) where - sgr2 = MGrammar [m | m@(i,_) <- modules sgr, notElem (prt i) $ map fileBody fs] compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv compileOne opts env@(_,srcgr) file = do @@ -125,19 +135,25 @@ compileSourceModule opts env@(k,gr) mo@(i,mi) = do mos = modules gr mo1 <- ioeErr $ rebuildModule mos mo + intermOut opts (iOpt "show_rebuild") (prMod mo1) mo1b <- ioeErr $ extendModule mos mo1 + intermOut opts (iOpt "show_extend") (prMod mo1b) case mo1b of (_,ModMod n) | not (isCompleteModule n) -> do return (k,mo1b) -- refresh would fail, since not renamed _ -> do mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b + intermOut opts (iOpt "show_rename") (prMod mo2) (mo3:_,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule mos mo2 if null warnings then return () else putp warnings $ return () + intermOut opts (iOpt "show_typecheck") (prMod mo3) + (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 + intermOut opts (iOpt "show_refresh") (prMod mo3r) let eenv = emptyEEnv (mo4,eenv') <- diff --git a/src/GF/Devel/GFC.hs b/src/GF/Devel/GFC.hs index f6753e31f..6d9108eea 100644 --- a/src/GF/Devel/GFC.hs +++ b/src/GF/Devel/GFC.hs @@ -2,6 +2,9 @@ module Main where import GF.Devel.Compile import GF.Devel.GrammarToGFCC +import GF.Canon.GFCC.CheckGFCC +import GF.Canon.GFCC.PrintGFCC +import GF.Canon.GFCC.DataGFCC import GF.Devel.UseIO import GF.Infra.Option ---import GF.Devel.PrGrammar --- @@ -17,10 +20,19 @@ main = do _ | oElem (iOpt "-make") opts -> do gr <- batchCompile opts fs let name = justModuleName (last fs) - let (abs,gc) = prGrammar2gfcc opts name gr + let (abs,gc) = mkCanon2gfcc opts name gr + + if oElem (iOpt "check") opts then (check gc) else return () + let target = abs ++ ".gfcc" - writeFile target gc + writeFile target (printTree gc) putStrLn $ "wrote file " ++ target _ -> do mapM_ (batchCompile opts) (map return fs) putStrLn "Done." + +check gc = do + let gfcc = mkGFCC gc + b <- checkGFCC gfcc + putStrLn $ if b then "OK" else "Corrupted GFCC" + diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs index 38811f80d..2742629d5 100644 --- a/src/GF/Devel/GrammarToGFCC.hs +++ b/src/GF/Devel/GrammarToGFCC.hs @@ -1,4 +1,4 @@ -module GF.Devel.GrammarToGFCC (prGrammar2gfcc) where +module GF.Devel.GrammarToGFCC (prGrammar2gfcc,mkCanon2gfcc) where import GF.Grammar.Grammar import qualified GF.Grammar.Lookup as Look