From 7aedefa5fb9fba467d64ed923d42f9e56aa2b72d Mon Sep 17 00:00:00 2001 From: aarne Date: Tue, 8 Mar 2005 17:08:58 +0000 Subject: [PATCH] auto-insert default lincat; eliminate deps bug; less verbosity in import; take away word order variants in Scand --- lib/resource/scandinavian/SyntaxScand.gf | 3 ++ src/GF/API/IOGrammar.hs | 12 ++--- src/GF/Compile/CheckGrammar.hs | 41 ++++++++++------ src/GF/Compile/Compile.hs | 62 +++++++++++++----------- src/GF/Compile/ModDeps.hs | 8 +-- src/GF/Compile/Rebuild.hs | 11 +++-- src/GF/Infra/ReadFiles.hs | 12 ++--- src/GF/Infra/UseIO.hs | 18 +++++-- 8 files changed, 98 insertions(+), 69 deletions(-) diff --git a/lib/resource/scandinavian/SyntaxScand.gf b/lib/resource/scandinavian/SyntaxScand.gf index 0dd61e7c8..cac9050a3 100644 --- a/lib/resource/scandinavian/SyntaxScand.gf +++ b/lib/resource/scandinavian/SyntaxScand.gf @@ -903,6 +903,8 @@ oper idag = sats.s6 ; exts = sats.s7 in case osf.o of { + Main => jag ++ har ++ inte ++ sagt ++ dig ++ idag ++ exts ; +{- Main => variants { jag ++ har ++ inte ++ sagt ++ dig ++ idag ++ exts ; onlyIf (orB sats.e3 (notB b)) @@ -916,6 +918,7 @@ oper onlyIf sats.e7 (exts ++ har ++ jag ++ inte ++ sagt ++ dig ++ idag) } ; +-} Inv => har ++ jag ++ inte ++ sagt ++ dig ++ idag ++ exts ; Sub => diff --git a/src/GF/API/IOGrammar.hs b/src/GF/API/IOGrammar.hs index 7abeead08..c2c2628ba 100644 --- a/src/GF/API/IOGrammar.hs +++ b/src/GF/API/IOGrammar.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/02/18 19:21:06 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.14 $ +-- > CVS $Date: 2005/03/08 18:08:58 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.15 $ -- -- for reading grammars and terms from strings and files ----------------------------------------------------------------------------- @@ -55,7 +55,7 @@ shellStateFromFiles opts st file = case fileSuffix file of cenv <- compileOne opts (compileEnvShSt st []) file ioeErr $ updateShellState opts Nothing st cenv s | elem s ["cf","ebnf"] -> do - let osb = addOptions (options [beVerbose]) opts + let osb = addOptions (options []) opts grts <- compileModule osb st file ioeErr $ updateShellState opts Nothing st grts _ -> do @@ -63,8 +63,8 @@ shellStateFromFiles opts st file = case fileSuffix file of let opts' = if b then (addOption showOld opts) else opts let osb = if oElem showOld opts' - then addOptions (options [beVerbose]) opts' -- for old no emit - else addOptions (options [beVerbose, emitCode]) opts' + then addOptions (options []) opts' -- for old no emit + else addOptions (options [emitCode]) opts' grts <- compileModule osb st file let top = identC $ justModuleName file ioeErr $ updateShellState opts' (Just top) st grts diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 7e6f3f117..38a900981 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/02/18 19:21:08 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.20 $ +-- > CVS $Date: 2005/03/08 18:08:58 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.21 $ -- -- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003 -- @@ -63,8 +63,8 @@ checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod MTConcrete a -> do ModMod abs <- checkErr $ lookupModule gr a - checkCompleteGrammar abs mo - mapMTree (checkCncInfo gr name (a,abs)) js + js1 <- checkCompleteGrammar abs mo + mapMTree (checkCncInfo gr name (a,abs)) js1 MTInterface -> mapMTree (checkResInfo gr) js @@ -118,17 +118,26 @@ checkAbsInfo st m (c,info) = do _ -> composOp (compAbsTyp g) t -checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check () -checkCompleteGrammar abs cnc = mapM_ checkWarn $ - checkComplete [f | (f, AbsFun (Yes _) _) <- abs'] cnc' - where - abs' = tree2list $ jments abs - cnc' = mapTree fst $ jments cnc - checkComplete sought given = foldr ckOne [] sought - where - ckOne f = if isInBinTree f given - then id - else (("Warning: no linearization of" +++ prt f):) +checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check (BinTree (Ident,Info)) +checkCompleteGrammar abs cnc = do + let js = jments cnc + let fs = tree2list $ jments abs + foldM checkOne js fs + where + checkOne js i@(c,info) = case info of + AbsFun (Yes _) _ -> case lookupTree prt c js of + Ok _ -> return js + _ -> do + checkWarn $ "Warning: no linearization of" +++ prt c + return js + AbsCat (Yes _) _ -> case lookupTree prt c js of + Ok _ -> return js + _ -> do + checkWarn $ + "Warning: no linearization type for" +++ prt c ++ + ", inserting default {s : Str}" + return $ updateTree (c,CncCat (Yes defLinType) nope nope) js + _ -> return js -- | General Principle: only Yes-values are checked. -- A May-value has always been checked in its origin module. diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs index 729257f96..82f9d12a6 100644 --- a/src/GF/Compile/Compile.hs +++ b/src/GF/Compile/Compile.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/03/02 14:22:53 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.34 $ +-- > CVS $Date: 2005/03/08 18:08:58 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.35 $ -- -- The top-level compilation chain from source file to gfc\/gfr. ----------------------------------------------------------------------------- @@ -57,14 +57,14 @@ gfGrammarPathVar = "GF_LIB_PATH" -- | in batch mode: write code in a file batchCompile f = liftM fst $ compileModule defOpts emptyShellState f where - defOpts = options [beVerbose, emitCode] + defOpts = options [emitCode] batchCompileOpt f = liftM fst $ compileModule defOpts emptyShellState f where - defOpts = options [beVerbose, emitCode, optimizeCanon] + defOpts = options [emitCode, optimizeCanon] batchCompileOld f = compileOld defOpts f where - defOpts = options [beVerbose, emitCode] + defOpts = options [emitCode] -- | compile with one module as starting point -- command-line options override options (marked by --#) in the file @@ -76,7 +76,8 @@ compileModule :: Options -> ShellState -> FilePath -> IOE TimedCompileEnv compileModule opts st0 file | oElem showOld opts || elem suff ["cf","ebnf"] = do - let putp = putPointE opts + let putp = putPointE opts + let putpp = putPointEsil opts let path = [] ---- grammar1 <- if suff == "cf" then putp ("- parsing" +++ suff +++ file) $ getCFGrammar opts file @@ -85,12 +86,12 @@ compileModule opts st0 file | else putp ("- parsing old gf" +++ file) $ getOldGrammar opts file let mods = modules grammar1 let env = compileEnvShSt st0 [] - foldM (comp putp path) env mods + foldM (comp putpp path) env mods where suff = fileSuffix file - comp putp path env sm0 = do + comp putpp path env sm0 = do (k',sm) <- makeSourceModule opts (fst env) sm0 - cm <- putp " generating code... " $ generateModuleCode opts path sm + cm <- putpp " generating code... " $ generateModuleCode opts path sm ft <- getReadTimes file --- extendCompileEnvInt env (k',sm,cm) ft @@ -106,9 +107,8 @@ compileModule opts1 st0 file = do then (map (prefixPathName fpath) ps0) else ps0 ps <- ioeIO $ extendPathEnv gfGrammarPathVar ps1 - let ioeIOIf = if oElem beSilent opts then (const (return ())) else ioeIO + let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ())) ioeIOIf $ putStrLn $ "module search path:" +++ show ps ---- - let putp = putPointE opts let st = st0 --- if useFileOpt then emptyShellState else st0 let rfs = readFiles st let file' = if useFileOpt then justFileName file else file -- to find file itself @@ -166,6 +166,12 @@ compileOne :: Options -> TimedCompileEnv -> FullPath -> IOE TimedCompileEnv compileOne opts env@((_,srcgr,_),_) file = do let putp = putPointE opts + let putpp = putPointEsil opts + let putpOpt v m act + | oElem beVerbose opts = putp v act + | oElem beSilent opts = putpp v act + | otherwise = ioeIO (putStrFlush m) >> act + let gf = fileSuffix file let path = justInitPath file let name = fileBody file @@ -187,7 +193,7 @@ compileOne opts env@((_,srcgr,_),_) file = do -- for compiled resource, parse and organize, then update environment "gfr" -> do - sm0 <- putp ("| parsing" +++ file) $ getSourceModule file + sm0 <- putp ("| reading" +++ file) $ getSourceModule file sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm0 ---- experiment with not optimizing gfr ---- sm:_ <- putp " optimizing " $ ioeErr $ evalModule mos sm1 @@ -198,9 +204,9 @@ compileOne opts env@((_,srcgr,_),_) file = do -- for gf source, do full compilation _ -> do - sm0 <- putp ("- parsing" +++ file) $ getSourceModule file + sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ getSourceModule file (k',sm) <- makeSourceModule opts (fst env) sm0 - cm <- putp " generating code... " $ generateModuleCode opts path sm + cm <- putpp " generating code... " $ generateModuleCode opts path sm ft <- getReadTimes file sm':_ <- case snd sm of @@ -235,13 +241,14 @@ compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule) compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do - let putp = putPointE opts - mos = modules gr + let putp = putPointE opts + putpp = putPointEsil opts + mos = modules gr if (oElem showOld opts && oElem emitCode opts) then do let (file,out) = (gfFile (prt i), prGrammar (MGrammar [mo])) - ioeIO $ writeFile file out >> putStr (" wrote file" +++ file) + putp (" wrote file" +++ file) $ ioeIO $ writeFile file out else return () mo1 <- ioeErr $ rebuildModule mos mo @@ -252,17 +259,17 @@ compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do (_,ModMod n) | not (isCompleteModule n) -> do return (k,mo1b) -- refresh would fail, since not renamed _ -> do - mo2:_ <- putp " renaming " $ ioeErr $ renameModule mos mo1b + mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b - (mo3:_,warnings) <- putp " type checking" $ ioeErr $ showCheckModule mos mo2 - putStrE warnings + (mo3:_,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule mos mo2 + if null warnings then return () else putp warnings $ return () (k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3 mo4 <- ---- case snd mo1b of ---- ModMod n | isModCnc n -> - putp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r + putpp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r ---- _ -> return [mo3r] return (k',mo4) where @@ -291,17 +298,19 @@ generateModuleCode opts path minfo@(name,info) = do let rminfo = if isCompilable info then minfo else (name,emptyModInfo) let (file,out) = (gfrFile pname, prGrammar (MGrammar [rminfo])) - ioeIO $ writeFile file out >> putStr (" wrote file" +++ file) + putp (" wrote file" +++ file) $ ioeIO $ writeFile file out _ -> return () (file,out) <- do code <- return $ MkGFC.prCanonModInfo minfo' return (gfcFile pname, code) if emit && nomulti ---- && isCompilable info - then ioeIO (writeFile file out) >> ioeIOIf (putStr (" wrote file" +++ file)) - else ioeIOIf $ putStrFlush $ "no need to save module" +++ prt name + then putp (" wrote file" +++ file) $ ioeIO $ writeFile file out + else putpp ("no need to save module" +++ prt name) $ return () return minfo' where - ioeIOIf = if oElem beSilent opts then (const (return ())) else ioeIO + putp = putPointE opts + putpp = putPointEsil opts + emitsGFR m = isModRes m ---- && isCompilable info ---- isModRes m || (isModCnc m && mstatus m == MSIncomplete) isCompilable mi = case mi of @@ -326,4 +335,3 @@ writeNewGF m@(i,_) = do ioeIO $ writeFile file $ prGrammar (MGrammar [m]) ioeIO $ putStrLn $ "wrote file" +++ file return file - diff --git a/src/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs index eaf5d7daf..6e38d9e3b 100644 --- a/src/GF/Compile/ModDeps.hs +++ b/src/GF/Compile/ModDeps.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/02/18 19:21:09 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.11 $ +-- > CVS $Date: 2005/03/08 18:08:58 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.12 $ -- -- Check correctness of module dependencies. Incomplete. -- @@ -74,7 +74,7 @@ moduleDeps ms = mapM deps ms where ModMod m -> case mtype m of MTConcrete a -> do aty <- lookupModuleType gr a - testErr (aty == MTAbstract) "the for-module is not an abstract syntax" + 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 diff --git a/src/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs index 1dee8624c..b00397eb9 100644 --- a/src/GF/Compile/Rebuild.hs +++ b/src/GF/Compile/Rebuild.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/02/18 19:21:09 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.9 $ +-- > CVS $Date: 2005/03/08 18:08:58 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.10 $ -- -- Rebuild a source module from incomplete and its with-instance. ----------------------------------------------------------------------------- @@ -30,8 +30,9 @@ import Operations rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule rebuildModule ms mo@(i,mi) = do let gr = MGrammar ms - deps <- moduleDeps ms - is <- openInterfaces deps i +---- deps <- moduleDeps ms +---- is <- openInterfaces deps i + let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005 mi' <- case mi of -- add the information given in interface into an instance module diff --git a/src/GF/Infra/ReadFiles.hs b/src/GF/Infra/ReadFiles.hs index d65ffedfb..9315633b3 100644 --- a/src/GF/Infra/ReadFiles.hs +++ b/src/GF/Infra/ReadFiles.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/02/18 19:21:15 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.19 $ +-- > CVS $Date: 2005/03/08 18:08:58 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.20 $ -- -- Decide what files to read as function of dependencies and time stamps. -- @@ -45,9 +45,9 @@ getAllFiles opts ps env file = do -- read module headers from all files recursively ds0 <- getImports ps file let ds = [((snd m,map fst ms),p) | ((m,ms),p) <- ds0] - if oElem beSilent opts - then return () - else ioeIO $ putStrLn $ "all modules:" +++ show (map (fst . fst) ds) + if oElem beVerbose opts + then ioeIO $ putStrLn $ "all modules:" +++ show (map (fst . fst) ds) + else return () -- get a topological sorting of files: returns file names --- deletes paths ds1 <- ioeErr $ either return diff --git a/src/GF/Infra/UseIO.hs b/src/GF/Infra/UseIO.hs index 51dfc71e8..9aabd0f3e 100644 --- a/src/GF/Infra/UseIO.hs +++ b/src/GF/Infra/UseIO.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/02/24 11:46:36 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.9 $ +-- > CVS $Date: 2005/03/08 18:08:58 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.10 $ -- -- (Description of the module) ----------------------------------------------------------------------------- @@ -227,9 +227,17 @@ putStrLnE = ioeIO . putStrLnFlush putStrE :: String -> IOE () putStrE = ioeIO . putStrFlush +-- this is more verbose putPointE :: Options -> String -> IOE a -> IOE a -putPointE opts msg act = do - let ve x = if oElem beSilent opts then return () else x +putPointE = putPointEgen (oElem beSilent) + +-- this is less verbose +putPointEsil :: Options -> String -> IOE a -> IOE a +putPointEsil = putPointEgen (not . oElem beVerbose) + +putPointEgen :: (Options -> Bool) -> Options -> String -> IOE a -> IOE a +putPointEgen cond opts msg act = do + let ve x = if cond opts then return () else x ve $ ioeIO $ putStrFlush msg a <- act --- ve $ ioeIO $ putShow' id a --- replace by a statistics command