content: 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 GF.Text.Pretty
  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) $ liftIO $ 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 md mr mprn _)      = maybe (loc "lincat")       mty ++ 
                                                    maybe (loc "lindef")       md  ++
                                                    maybe (loc "linref")       mr  ++
                                                    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" ++ render m ++ "\t\t" ++ gf2gftags opts (orig mi info)
              | (id,info) <- Map.toList (jments mi), filter incl id]
      toDep (OQualif m1 m2,incl) =
        let Ok mi = lookupModule gr m2
        in [showIdent id ++ "\t" ++ "indir" ++ "\t" ++ render m2 ++ "\t" ++ render m1 ++ "\t" ++ gf2gftags opts (orig mi info)
              | (id,info) <- Map.toList (jments mi), filter incl id]
  
      filter MIAll          id = True
      filter (MIOnly   ids) id = elem id ids
      filter (MIExcept ids) id = not (elem id ids)
  
      orig mi info =
        case info of
          AnyInd _ m0 -> let Ok mi0 = lookupModule gr m0
                         in msrc mi0
          _           ->    msrc mi 
  
  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)
  