the new design for -tags

2 files changed, 84 insertions, 4 deletions

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/GF/Compile/Tags.hs b/src/compiler/GF/Compile/Tags.hs
new file mode 100644
index 000000000..f2c0db861
--- /dev/null
+++ b/src/compiler/GF/Compile/Tags.hs
@@ -0,0 +1,83 @@
+module GF.Compile.Tags
+         ( writeTags
+         , gf2gftags
+         ) where
+
+import GF.Infra.Option
+import GF.Infra.UseIO
+import GF.Data.Operations
+import GF.Grammar
+
+import Data.List
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Control.Monad
+import Text.PrettyPrint
+import System.FilePath
+
+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
+
+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
+    getLocations :: Info -> [(String,String,String)]
+    getLocations (AbsCat mb_ctxt)               = maybe (loc "cat")          mb_ctxt
+    getLocations (AbsFun mb_type _ mb_eqs _)    = maybe (ltype "fun")        mb_type ++
+                                                  maybe (list (loc "def"))   mb_eqs  
+    getLocations (ResParam mb_params _)         = maybe (loc "param")        mb_params
+    getLocations (ResValue mb_type)             = ltype "param-value"          mb_type
+    getLocations (ResOper  mb_type mb_def)      = maybe (ltype "oper-type")  mb_type ++
+                                                  maybe (loc "oper-def")     mb_def
+    getLocations (ResOverload _ defs)           = list (\(x,y) -> ltype "overload-type" x ++ 
+                                                                  loc   "overload-def"  y) defs
+    getLocations (CncCat mty mdef mprn _)       = maybe (loc "lincat")       mty ++ 
+                                                  maybe (loc "lindef")       mdef  ++ 
+                                                  maybe (loc "printname")    mprn
+    getLocations (CncFun _ mlin mprn _)         = maybe (loc "lin")          mlin ++
+                                                  maybe (loc "printname")    mprn
+    getLocations _                              = []
+
+    loc kind (L loc _) = [(kind,render (ppLocation (msrc mi) loc),"")]
+
+    ltype kind (L loc ty) = [(kind,render (ppLocation (msrc mi) loc),render (ppTerm Unqualified 0 ty))]
+
+    maybe f (Just x) = f x
+    maybe f Nothing  = []
+
+    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)