msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

the new design for -tags

Browse Source
This commit is contained in:
kr.angelov
2011-11-14 16:08:56 +00:00
parent 970d42da2b
commit e161f93f4d
5 changed files with 80 additions and 45 deletions
Download Patch File Download Diff File Expand all files Collapse all files

59
src/compiler/GF/Compile.hs
View File

@@ -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

5
src/compiler/GF/Compile/Rename.hs
View File

@@ -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 =

83
src/compiler/GF/Compile/Tags.hs Normal file
View File

@@ -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)

10
src/compiler/GF/Infra/Option.hs
View File

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