diff options
Diffstat (limited to 'src/compiler/GF/Compile')
| -rw-r--r-- | src/compiler/GF/Compile/Rename.hs | 5 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Tags.hs | 83 |
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) |