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 :: Options -> Grammar -> String -> (a, ModuleInfo) -> m ()
writeTags Options
opts Grammar
gr String
file (a, ModuleInfo)
mo = do
  let imports :: [String]
imports = Options -> Grammar -> (a, ModuleInfo) -> [String]
forall a. Options -> Grammar -> (a, ModuleInfo) -> [String]
getImports Options
opts Grammar
gr (a, ModuleInfo)
mo
      locals :: [String]
locals  = [String] -> (a, ModuleInfo) -> [String]
forall a. [String] -> (a, ModuleInfo) -> [String]
getLocalTags [] (a, ModuleInfo)
mo
      txt :: String
txt     = [String] -> String
unlines ((Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String -> [String])
-> ([String] -> Set String) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList) ([String]
imports[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
locals))
  Verbosity -> Options -> String -> m () -> m ()
forall (m :: * -> *) b.
(Output m, MonadIO m) =>
Verbosity -> Options -> String -> m b -> m b
putPointE Verbosity
Normal Options
opts (String
"  write file" String -> String -> String
+++ String
file) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
file String
txt

getLocalTags :: [String] -> (a, ModuleInfo) -> [String]
getLocalTags [String]
x (a
m,ModuleInfo
mi) = 
  [Ident -> String
showIdent Ident
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t 
       | (Ident
i,Info
jment) <- Map Ident Info -> [(Ident, Info)]
forall k a. Map k a -> [(k, a)]
Map.toList (ModuleInfo -> Map Ident Info
jments ModuleInfo
mi),
         (String
k,String
l,String
t)   <- Info -> [(String, String, String)]
getLocations Info
jment] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
x
  where
    getLocations :: Info -> [(String,String,String)]
    getLocations :: Info -> [(String, String, String)]
getLocations (AbsCat Maybe (L Context)
mb_ctxt)               = (L Context -> [(String, String, String)])
-> Maybe (L Context) -> [(String, String, String)]
forall t a. (t -> [a]) -> Maybe t -> [a]
maybe (String -> L Context -> [(String, String, String)]
forall a a. a -> L a -> [(a, String, String)]
loc String
"cat")          Maybe (L Context)
mb_ctxt
    getLocations (AbsFun Maybe (L Type)
mb_type Maybe Int
_ Maybe [L Equation]
mb_eqs Maybe Bool
_)    = (L Type -> [(String, String, String)])
-> Maybe (L Type) -> [(String, String, String)]
forall t a. (t -> [a]) -> Maybe t -> [a]
maybe (String -> L Type -> [(String, String, String)]
forall a. a -> L Type -> [(a, String, String)]
ltype String
"fun")        Maybe (L Type)
mb_type [(String, String, String)]
-> [(String, String, String)] -> [(String, String, String)]
forall a. [a] -> [a] -> [a]
++
                                                  ([L Equation] -> [(String, String, String)])
-> Maybe [L Equation] -> [(String, String, String)]
forall t a. (t -> [a]) -> Maybe t -> [a]
maybe ((L Equation -> [(String, String, String)])
-> [L Equation] -> [(String, String, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
list (String -> L Equation -> [(String, String, String)]
forall a a. a -> L a -> [(a, String, String)]
loc String
"def"))   Maybe [L Equation]
mb_eqs  
    getLocations (ResParam Maybe (L [Param])
mb_params Maybe [Type]
_)         = (L [Param] -> [(String, String, String)])
-> Maybe (L [Param]) -> [(String, String, String)]
forall t a. (t -> [a]) -> Maybe t -> [a]
maybe (String -> L [Param] -> [(String, String, String)]
forall a a. a -> L a -> [(a, String, String)]
loc String
"param")        Maybe (L [Param])
mb_params
    getLocations (ResValue L Type
mb_type)             = String -> L Type -> [(String, String, String)]
forall a. a -> L Type -> [(a, String, String)]
ltype String
"param-value"          L Type
mb_type
    getLocations (ResOper  Maybe (L Type)
mb_type Maybe (L Type)
mb_def)      = (L Type -> [(String, String, String)])
-> Maybe (L Type) -> [(String, String, String)]
forall t a. (t -> [a]) -> Maybe t -> [a]
maybe (String -> L Type -> [(String, String, String)]
forall a. a -> L Type -> [(a, String, String)]
ltype String
"oper-type")  Maybe (L Type)
mb_type [(String, String, String)]
-> [(String, String, String)] -> [(String, String, String)]
forall a. [a] -> [a] -> [a]
++
                                                  (L Type -> [(String, String, String)])
-> Maybe (L Type) -> [(String, String, String)]
forall t a. (t -> [a]) -> Maybe t -> [a]
maybe (String -> L Type -> [(String, String, String)]
forall a a. a -> L a -> [(a, String, String)]
loc String
"oper-def")     Maybe (L Type)
mb_def
    getLocations (ResOverload [ModuleName]
_ [(L Type, L Type)]
defs)           = ((L Type, L Type) -> [(String, String, String)])
-> [(L Type, L Type)] -> [(String, String, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
list (\(L Type
x,L Type
y) -> String -> L Type -> [(String, String, String)]
forall a. a -> L Type -> [(a, String, String)]
ltype String
"overload-type" L Type
x [(String, String, String)]
-> [(String, String, String)] -> [(String, String, String)]
forall a. [a] -> [a] -> [a]
++ 
                                                                  String -> L Type -> [(String, String, String)]
forall a a. a -> L a -> [(a, String, String)]
loc   String
"overload-def"  L Type
y) [(L Type, L Type)]
defs
    getLocations (CncCat Maybe (L Type)
mty Maybe (L Type)
md Maybe (L Type)
mr Maybe (L Type)
mprn Maybe PMCFG
_)      = (L Type -> [(String, String, String)])
-> Maybe (L Type) -> [(String, String, String)]
forall t a. (t -> [a]) -> Maybe t -> [a]
maybe (String -> L Type -> [(String, String, String)]
forall a a. a -> L a -> [(a, String, String)]
loc String
"lincat")       Maybe (L Type)
mty [(String, String, String)]
-> [(String, String, String)] -> [(String, String, String)]
forall a. [a] -> [a] -> [a]
++ 
                                                  (L Type -> [(String, String, String)])
-> Maybe (L Type) -> [(String, String, String)]
forall t a. (t -> [a]) -> Maybe t -> [a]
maybe (String -> L Type -> [(String, String, String)]
forall a a. a -> L a -> [(a, String, String)]
loc String
"lindef")       Maybe (L Type)
md  [(String, String, String)]
-> [(String, String, String)] -> [(String, String, String)]
forall a. [a] -> [a] -> [a]
++
                                                  (L Type -> [(String, String, String)])
-> Maybe (L Type) -> [(String, String, String)]
forall t a. (t -> [a]) -> Maybe t -> [a]
maybe (String -> L Type -> [(String, String, String)]
forall a a. a -> L a -> [(a, String, String)]
loc String
"linref")       Maybe (L Type)
mr  [(String, String, String)]
-> [(String, String, String)] -> [(String, String, String)]
forall a. [a] -> [a] -> [a]
++
                                                  (L Type -> [(String, String, String)])
-> Maybe (L Type) -> [(String, String, String)]
forall t a. (t -> [a]) -> Maybe t -> [a]
maybe (String -> L Type -> [(String, String, String)]
forall a a. a -> L a -> [(a, String, String)]
loc String
"printname")    Maybe (L Type)
mprn
    getLocations (CncFun Maybe (Ident, Context, Type)
_ Maybe (L Type)
mlin Maybe (L Type)
mprn Maybe PMCFG
_)         = (L Type -> [(String, String, String)])
-> Maybe (L Type) -> [(String, String, String)]
forall t a. (t -> [a]) -> Maybe t -> [a]
maybe (String -> L Type -> [(String, String, String)]
forall a a. a -> L a -> [(a, String, String)]
loc String
"lin")          Maybe (L Type)
mlin [(String, String, String)]
-> [(String, String, String)] -> [(String, String, String)]
forall a. [a] -> [a] -> [a]
++
                                                  (L Type -> [(String, String, String)])
-> Maybe (L Type) -> [(String, String, String)]
forall t a. (t -> [a]) -> Maybe t -> [a]
maybe (String -> L Type -> [(String, String, String)]
forall a a. a -> L a -> [(a, String, String)]
loc String
"printname")    Maybe (L Type)
mprn
    getLocations Info
_                              = []

    loc :: a -> L a -> [(a, String, String)]
loc a
kind (L Location
loc a
_) = [(a
kind,Doc -> String
render (String -> Location -> Doc
ppLocation (ModuleInfo -> String
msrc ModuleInfo
mi) Location
loc),String
"")]

    ltype :: a -> L Type -> [(a, String, String)]
ltype a
kind (L Location
loc Type
ty) = [(a
kind,Doc -> String
render (String -> Location -> Doc
ppLocation (ModuleInfo -> String
msrc ModuleInfo
mi) Location
loc),Doc -> String
render (TermPrintQual -> Integer -> Type -> Doc
forall t. (Ord t, Num t) => TermPrintQual -> t -> Type -> Doc
ppTerm TermPrintQual
Unqualified Integer
0 Type
ty))]

    maybe :: (t -> [a]) -> Maybe t -> [a]
maybe t -> [a]
f (Just t
x) = t -> [a]
f t
x
    maybe t -> [a]
f Maybe t
Nothing  = []

    list :: (a -> [b]) -> t a -> [b]
list a -> [b]
f t a
xs = (a -> [b]) -> t a -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [b]
f t a
xs
    
    render :: Doc -> String
render = Style -> Doc -> String
forall a. Pretty a => Style -> a -> String
renderStyle Style
style{mode :: Mode
mode=Mode
OneLineMode}


getImports :: Options -> Grammar -> (a, ModuleInfo) -> [String]
getImports Options
opts Grammar
gr mo :: (a, ModuleInfo)
mo@(a
m,ModuleInfo
mi) = ((OpenSpec, MInclude) -> [String])
-> [(OpenSpec, MInclude)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (OpenSpec, MInclude) -> [String]
toDep [(OpenSpec, MInclude)]
allOpens
  where
    allOpens :: [(OpenSpec, MInclude)]
allOpens = [(ModuleName -> OpenSpec
OSimple ModuleName
m,MInclude
incl) | (ModuleName
m,MInclude
incl) <- ModuleInfo -> [(ModuleName, MInclude)]
mextend ModuleInfo
mi] [(OpenSpec, MInclude)]
-> [(OpenSpec, MInclude)] -> [(OpenSpec, MInclude)]
forall a. [a] -> [a] -> [a]
++ 
               [(OpenSpec
o,MInclude
MIAll) | OpenSpec
o <- ModuleInfo -> [OpenSpec]
mopens ModuleInfo
mi]

    toDep :: (OpenSpec, MInclude) -> [String]
toDep (OSimple ModuleName
m,MInclude
incl)     =
      let Ok ModuleInfo
mi = Grammar -> ModuleName -> Err ModuleInfo
forall (m :: * -> *).
ErrorMonad m =>
Grammar -> ModuleName -> m ModuleInfo
lookupModule Grammar
gr ModuleName
m
      in [Ident -> String
showIdent Ident
id String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"indir" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
forall a. Pretty a => a -> String
render ModuleName
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\t\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Options -> String -> String
gf2gftags Options
opts (ModuleInfo -> Info -> String
orig ModuleInfo
mi Info
info)
            | (Ident
id,Info
info) <- Map Ident Info -> [(Ident, Info)]
forall k a. Map k a -> [(k, a)]
Map.toList (ModuleInfo -> Map Ident Info
jments ModuleInfo
mi), MInclude -> Ident -> Bool
filter MInclude
incl Ident
id]
    toDep (OQualif ModuleName
m1 ModuleName
m2,MInclude
incl) =
      let Ok ModuleInfo
mi = Grammar -> ModuleName -> Err ModuleInfo
forall (m :: * -> *).
ErrorMonad m =>
Grammar -> ModuleName -> m ModuleInfo
lookupModule Grammar
gr ModuleName
m2
      in [Ident -> String
showIdent Ident
id String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"indir" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
forall a. Pretty a => a -> String
render ModuleName
m2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
forall a. Pretty a => a -> String
render ModuleName
m1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Options -> String -> String
gf2gftags Options
opts (ModuleInfo -> Info -> String
orig ModuleInfo
mi Info
info)
            | (Ident
id,Info
info) <- Map Ident Info -> [(Ident, Info)]
forall k a. Map k a -> [(k, a)]
Map.toList (ModuleInfo -> Map Ident Info
jments ModuleInfo
mi), MInclude -> Ident -> Bool
filter MInclude
incl Ident
id]

    filter :: MInclude -> Ident -> Bool
filter MInclude
MIAll          Ident
id = Bool
True
    filter (MIOnly   [Ident]
ids) Ident
id = Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Ident
id [Ident]
ids
    filter (MIExcept [Ident]
ids) Ident
id = Bool -> Bool
not (Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Ident
id [Ident]
ids)

    orig :: ModuleInfo -> Info -> String
orig ModuleInfo
mi Info
info =
      case Info
info of
        AnyInd Bool
_ ModuleName
m0 -> let Ok ModuleInfo
mi0 = Grammar -> ModuleName -> Err ModuleInfo
forall (m :: * -> *).
ErrorMonad m =>
Grammar -> ModuleName -> m ModuleInfo
lookupModule Grammar
gr ModuleName
m0
                       in ModuleInfo -> String
msrc ModuleInfo
mi0
        Info
_           ->    ModuleInfo -> String
msrc ModuleInfo
mi 

gftagsFile :: FilePath -> FilePath
gftagsFile :: String -> String
gftagsFile String
f = String -> String -> String
addExtension String
f String
"gf-tags"

gf2gftags :: Options -> FilePath -> FilePath
gf2gftags :: Options -> String -> String
gf2gftags Options
opts String
file = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> String
gftagsFile (String -> String
dropExtension String
file))
                            (\String
dir -> String
dir String -> String -> String
</> String -> String
gftagsFile (String -> String
dropExtension (String -> String
takeFileName String
file)))
                            ((Flags -> Maybe String) -> Options -> Maybe String
forall a. (Flags -> a) -> Options -> a
flag Flags -> Maybe String
optOutputDir Options
opts)