From e161f93f4d73cfd2104336ad360a7e77a2c1fbc9 Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Mon, 14 Nov 2011 16:08:56 +0000 Subject: [PATCH] the new design for -tags --- src/compiler/GF.hs | 2 - src/compiler/GF/Compile.hs | 59 ++++++++++--------- src/compiler/GF/Compile/Rename.hs | 5 +- .../{GFTags.hs => GF/Compile/Tags.hs} | 49 ++++++++++++--- src/compiler/GF/Infra/Option.hs | 10 ++-- 5 files changed, 80 insertions(+), 45 deletions(-) rename src/compiler/{GFTags.hs => GF/Compile/Tags.hs} (54%) diff --git a/src/compiler/GF.hs b/src/compiler/GF.hs index bb68f5de6..43a2a0b7f 100644 --- a/src/compiler/GF.hs +++ b/src/compiler/GF.hs @@ -3,7 +3,6 @@ module Main where import GFC import GFI -import GFTags import GF.Data.ErrM import GF.Infra.Option import GF.Infra.UseIO @@ -48,4 +47,3 @@ mainOpts opts files = ModeRun -> mainRunGFI opts files ModeServer -> mainServerGFI opts files ModeCompiler -> dieIOE (mainGFC opts files) - ModeTags -> dieIOE (mainTags opts files) diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index 597044845..aac2a0fb7 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -11,8 +11,8 @@ import GF.Compile.GrammarToPGF import GF.Compile.ReadFiles import GF.Compile.Update import GF.Compile.Refresh - import GF.Compile.Coding +import GF.Compile.Tags import GF.Grammar.Grammar import GF.Grammar.Lookup @@ -23,7 +23,6 @@ import GF.Infra.Ident import GF.Infra.Option import GF.Infra.UseIO import GF.Infra.CheckM - import GF.Data.Operations import Control.Monad @@ -130,11 +129,10 @@ compileOne opts env@(_,srcgr,_) file = do | verbAtLeast opts Normal = ioeIO (putStrFlush m) >> act | otherwise = putPointE Verbose opts v act - let gf = takeExtensions file let path = dropFileName file let name = dropExtension file - case gf of + case takeExtensions file of -- for compiled gf, read the file and update environment -- also undo common subexp optimization, to enable normal computations @@ -146,16 +144,19 @@ compileOne opts env@(_,srcgr,_) file = do let sm1 = unsubexpModule sm0 sm <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ extendModule srcgr sm1 - + + if flag optTagsOnly opts + then writeTags opts srcgr (gf2gftags opts file) sm1 + else return () + extendCompileEnv env file sm -- for gf source, do full compilation and generate code _ -> do - let gfo = gf2gfo opts file b1 <- ioeIO $ doesFileExist file if not b1 - then compileOne opts env $ gfo + then compileOne opts env $ (gf2gfo opts file) else do sm00 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ @@ -165,16 +166,16 @@ compileOne opts env@(_,srcgr,_) file = do intermOut opts DumpSource (ppModule Qualified sm) - compileSourceModule opts env (Just gfo) sm + compileSourceModule opts env (Just file) sm where isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete compileSourceModule :: Options -> CompileEnv -> Maybe FilePath -> SourceModule -> IOE CompileEnv -compileSourceModule opts env@(k,gr,_) mb_gfo mo@(i,mi) = do +compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do let puts = putPointE Quiet opts putpp = putPointE Verbose opts - + mo1 <- ioeErr $ rebuildModule gr mo intermOut opts DumpRebuild (ppModule Qualified mo1) @@ -182,14 +183,17 @@ compileSourceModule opts env@(k,gr,_) mb_gfo mo@(i,mi) = do intermOut opts DumpExtend (ppModule Qualified mo1b) case mo1b of - (_,n) | not (isCompleteModule n) -> do - case mb_gfo of - Just gfo -> if flag optMode opts /= ModeTags - then writeGFO opts gfo mo1b - else putStrLnE "" - Nothing -> return () - - extendCompileEnvInt env k mb_gfo mo1b + (_,n) | not (isCompleteModule n) -> + if not (flag optTagsOnly opts) + then do let mb_gfo = fmap (gf2gfo opts) mb_gfFile + case mb_gfo of + Just gfo -> writeGFO opts gfo mo1b + Nothing -> return () + extendCompileEnvInt env k mb_gfo mo1b + else do case mb_gfFile of + Just gfFile -> writeTags opts gr (gf2gftags opts gfFile) mo1b + Nothing -> return () + extendCompileEnvInt env k Nothing mo1b _ -> do let mos = modules gr @@ -201,7 +205,7 @@ compileSourceModule opts env@(k,gr,_) mb_gfo mo@(i,mi) = do if null warnings then return () else puts warnings $ return () intermOut opts DumpTypeCheck (ppModule Qualified mo3) - if flag optMode opts /= ModeTags + if not (flag optTagsOnly opts) then do (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 intermOut opts DumpRefresh (ppModule Qualified mo3r) @@ -213,13 +217,16 @@ compileSourceModule opts env@(k,gr,_) mb_gfo mo@(i,mi) = do else return mo4 intermOut opts DumpCanon (ppModule Qualified mo5) + let mb_gfo = fmap (gf2gfo opts) mb_gfFile case mb_gfo of Just gfo -> writeGFO opts gfo mo5 Nothing -> return () extendCompileEnvInt env k' mb_gfo mo5 - else do putStrLnE "" - extendCompileEnvInt env k mb_gfo mo3 + else do case mb_gfFile of + Just gfFile -> writeTags opts gr (gf2gftags opts gfFile) mo3 + Nothing -> return () + extendCompileEnvInt env k Nothing mo3 writeGFO :: Options -> FilePath -> SourceModule -> IOE () @@ -236,15 +243,13 @@ writeGFO opts file mo = do emptyCompileEnv :: CompileEnv emptyCompileEnv = (0,emptySourceGrammar,Map.empty) -extendCompileEnvInt (_,gr,menv) k mfile sm = do - let (mod,imps) = importsOfModule sm +extendCompileEnvInt (_,gr,menv) k mfile mo = do menv2 <- case mfile of Just file -> do + let (mod,imps) = importsOfModule mo t <- ioeIO $ getModificationTime file return $ Map.insert mod (t,imps) menv _ -> return menv - return (k,prependModule gr sm,menv2) --- reverse later - -extendCompileEnv e@(k,_,_) file sm = extendCompileEnvInt e k (Just file) sm - + return (k,prependModule gr mo,menv2) --- reverse later +extendCompileEnv e@(k,_,_) file mo = extendCompileEnvInt e k (Just file) mo diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index 336e8f946..1d3db181c 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -62,7 +62,7 @@ renameModule :: [SourceModule] -> SourceModule -> Check SourceModule renameModule ms mo@(m,mi) = checkIn (text "renaming module" <+> ppIdent m) $ do status <- buildStatus (mGrammar ms) m mi js <- checkMap (renameInfo status mo) (jments mi) - return (m, mi{mopens = map forceQualif (mopens mi), jments = js}) + return (m, mi{jments = js}) type Status = (StatusTree, [(OpenSpec, StatusTree)]) @@ -141,9 +141,6 @@ modInfo2status (o,mo) = (o,tree2status o (jments mo)) self2status :: Ident -> SourceModInfo -> StatusTree self2status c m = mapTree (info2status (Just c)) (jments m) -forceQualif o = case o of - OSimple i -> OQualif i i - OQualif _ i -> OQualif i i renameInfo :: Status -> SourceModule -> Ident -> Info -> Check Info renameInfo status (m,mi) i info = diff --git a/src/compiler/GFTags.hs b/src/compiler/GF/Compile/Tags.hs similarity index 54% rename from src/compiler/GFTags.hs rename to src/compiler/GF/Compile/Tags.hs index 15f85e351..f2c0db861 100644 --- a/src/compiler/GFTags.hs +++ b/src/compiler/GF/Compile/Tags.hs @@ -1,23 +1,28 @@ -module GFTags where +module GF.Compile.Tags + ( writeTags + , gf2gftags + ) where import GF.Infra.Option import GF.Infra.UseIO +import GF.Data.Operations import GF.Grammar -import GF.Compile import Data.List import qualified Data.Map as Map import qualified Data.Set as Set import Control.Monad import Text.PrettyPrint +import System.FilePath -mainTags opts files = do - gr <- batchCompile opts files - let tags = foldl getTags [] (modules gr) - ioeIO (writeFile "tags" (unlines ((Set.toList . Set.fromList) tags))) +writeTags opts gr file mo = do + let imports = getImports opts gr mo + locals = getLocalTags [] mo + txt = unlines ((Set.toList . Set.fromList) (imports++locals)) + putPointE Normal opts (" write file" +++ file) $ ioeIO $ writeFile file txt -getTags x (m,mi) = - [showIdent m ++ "." ++ showIdent i ++ "\t" ++ k ++ "\t" ++ l ++ "\t" ++ t +getLocalTags x (m,mi) = + [showIdent i ++ "\t" ++ k ++ "\t" ++ l ++ "\t" ++ t | (i,jment) <- Map.toList (jments mi), (k,l,t) <- getLocations jment] ++ x where @@ -48,3 +53,31 @@ getTags x (m,mi) = list f xs = concatMap f xs render = renderStyle style{mode=OneLineMode} + + +getImports opts gr mo@(m,mi) = concatMap toDep allOpens + where + allOpens = [(OSimple m,incl) | (m,incl) <- mextend mi] ++ + [(o,MIAll) | o <- mopens mi] + + toDep (OSimple m,incl) = + let Ok mi = lookupModule gr m + in [showIdent id ++ "\t" ++ "indir" ++ "\t" ++ showIdent m ++ "\t\t" ++ gf2gftags opts (msrc mi) + | id <- Map.keys (jments mi), filter incl id] + toDep (OQualif m1 m2,incl) = + let Ok mi = lookupModule gr m2 + in [showIdent id ++ "\t" ++ "indir" ++ "\t" ++ showIdent m2 ++ "\t" ++ showIdent m1 ++ "\t" ++ gf2gftags opts (msrc mi) + | id <- Map.keys (jments mi), filter incl id] + + filter MIAll id = True + filter (MIOnly ids) id = elem id ids + filter (MIExcept ids) id = not (elem id ids) + + +gftagsFile :: FilePath -> FilePath +gftagsFile f = addExtension f "gf-tags" + +gf2gftags :: Options -> FilePath -> FilePath +gf2gftags opts file = maybe (gftagsFile (dropExtension file)) + (\dir -> dir gftagsFile (dropExtension (takeFileName file))) + (flag optOutputDir opts) diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index 6a468d157..1f468f879 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -74,7 +74,7 @@ errors = fail . unlines -- Types data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeRun | ModeCompiler - | ModeServer | ModeTags + | ModeServer deriving (Show,Eq,Ord) data Verbosity = Quiet | Normal | Verbose | Debug @@ -167,7 +167,8 @@ data Flags = Flags { optLexer :: Maybe String, optUnlexer :: Maybe String, optWarnings :: [Warning], - optDump :: [Dump] + optDump :: [Dump], + optTagsOnly :: Bool } deriving (Show) @@ -269,7 +270,8 @@ defaultFlags = Flags { optLexer = Nothing, optUnlexer = Nothing, optWarnings = [], - optDump = [] + optDump = [], + optTagsOnly = False } -- Option descriptions @@ -285,7 +287,7 @@ optDescr = Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).", Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).", Option [] ["server"] (NoArg (mode ModeServer)) "Run in HTTP server mode.", - Option [] ["tags"] (NoArg (mode ModeTags)) "Build TAGS file and exit.", + Option [] ["tags"] (NoArg (set $ \o -> o{optMode = ModeCompiler, optTagsOnly = True})) "Build TAGS file and exit.", Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).", Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.", Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .",