the new design for -tags

5 files changed, 80 insertions, 45 deletions

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
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) .",