summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/compiler/GF.hs2
-rw-r--r--src/compiler/GF/Command/Importing.hs9
-rw-r--r--src/compiler/GF/Compile.hs47
-rw-r--r--src/compiler/GF/Compile/CheckGrammar.hs30
-rw-r--r--src/compiler/GF/Compile/Compute/AppPredefined.hs6
-rw-r--r--src/compiler/GF/Compile/GetGrammar.hs5
-rw-r--r--src/compiler/GF/Compile/GrammarToPGF.hs8
-rw-r--r--src/compiler/GF/Compile/Rename.hs27
-rw-r--r--src/compiler/GF/Compile/SubExOpt.hs2
-rw-r--r--src/compiler/GF/Compile/Update.hs45
-rw-r--r--src/compiler/GF/Grammar/Analyse.hs2
-rw-r--r--src/compiler/GF/Grammar/Binary.hs20
-rw-r--r--src/compiler/GF/Grammar/CF.hs21
-rw-r--r--src/compiler/GF/Grammar/EBNF.hs7
-rw-r--r--src/compiler/GF/Grammar/Grammar.hs14
-rw-r--r--src/compiler/GF/Grammar/Lookup.hs4
-rw-r--r--src/compiler/GF/Grammar/Macros.hs2
-rw-r--r--src/compiler/GF/Grammar/Parser.y20
-rw-r--r--src/compiler/GF/Grammar/Printer.hs20
-rw-r--r--src/compiler/GF/Infra/Modules.hs16
-rw-r--r--src/compiler/GF/Infra/Option.hs3
-rw-r--r--src/compiler/GFTags.hs51
22 files changed, 232 insertions, 129 deletions
diff --git a/src/compiler/GF.hs b/src/compiler/GF.hs
index 43a2a0b7f..bb68f5de6 100644
--- a/src/compiler/GF.hs
+++ b/src/compiler/GF.hs
@@ -3,6 +3,7 @@ module Main where
import GFC
import GFI
+import GFTags
import GF.Data.ErrM
import GF.Infra.Option
import GF.Infra.UseIO
@@ -47,3 +48,4 @@ mainOpts opts files =
ModeRun -> mainRunGFI opts files
ModeServer -> mainServerGFI opts files
ModeCompiler -> dieIOE (mainGFC opts files)
+ ModeTags -> dieIOE (mainTags opts files)
diff --git a/src/compiler/GF/Command/Importing.hs b/src/compiler/GF/Command/Importing.hs
index cbbb7a30e..d8b7f0e0c 100644
--- a/src/compiler/GF/Command/Importing.hs
+++ b/src/compiler/GF/Command/Importing.hs
@@ -55,12 +55,11 @@ importSource src0 opts files = do
-- for different cf formats
importCF opts files get = do
s <- fmap unlines $ mapM readFile files
- let cnc = justModuleName (last files)
- gf <- case get cnc s of
- Ok g -> return g
+ gf <- case get (last files) s of
+ Ok gf -> return gf
Bad s -> error s ----
Ok gr <- appIOE $ compileSourceGrammar opts gf
- epgf <- appIOE $ link opts (identC (BS.pack (cnc ++ "Abs"))) gr
+ epgf <- appIOE $ link opts (identC (BS.pack (justModuleName (last files) ++ "Abs"))) gr
case epgf of
Ok pgf -> return pgf
- Bad s -> error s ----
+ Bad s -> error s ----
diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs
index 4ab4a986a..5b3abb98c 100644
--- a/src/compiler/GF/Compile.hs
+++ b/src/compiler/GF/Compile.hs
@@ -70,12 +70,11 @@ batchCompile opts files = do
-- to compile a set of modules, e.g. an old GF or a .cf file
compileSourceGrammar :: Options -> SourceGrammar -> IOE SourceGrammar
compileSourceGrammar opts gr = do
- (_,gr',_) <- foldM compOne (0,emptySourceGrammar,Map.empty) (modules gr)
+ (_,gr',_) <- foldM (\env -> compileSourceModule opts env Nothing)
+ (0,emptySourceGrammar,Map.empty)
+ (modules gr)
return gr'
- where
- compOne env mo = do
- (k,mo') <- compileSourceModule opts env mo
- extendCompileEnvInt env k Nothing mo' --- file for the same of modif time...
+
-- to output an intermediate stage
intermOut :: Options -> Dump -> Doc -> IOE ()
@@ -161,18 +160,16 @@ compileOne opts env@(_,srcgr,_) file = do
sm00 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $
getSourceModule opts file
enc <- ioeIO $ mkTextEncoding (renameEncoding (flag optEncoding (flagsModule sm00)))
- let sm0 = decodeStringsInModule enc sm00
+ let sm = decodeStringsInModule enc sm00
- intermOut opts DumpSource (ppModule Qualified sm0)
+ intermOut opts DumpSource (ppModule Qualified sm)
- (k',sm) <- compileSourceModule opts env sm0
- putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo sm
- extendCompileEnvInt env k' (Just gfo) sm
+ compileSourceModule opts env (Just gfo) sm
where
isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete
-compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule)
-compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
+compileSourceModule :: Options -> CompileEnv -> Maybe FilePath -> SourceModule -> IOE CompileEnv
+compileSourceModule opts env@(k,gr,_) mb_gfo mo@(i,mi) = do
let puts = putPointE Quiet opts
putpp = putPointE Verbose opts
@@ -185,7 +182,13 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
case mo1b of
(_,n) | not (isCompleteModule n) -> do
- return (k,mo1b) -- refresh would fail, since not renamed
+ case mb_gfo of
+ Just gfo -> if flag optMode opts /= ModeTags
+ then putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo mo1b
+ else putStrLnE "" >> return mo1b
+ Nothing -> return mo1b
+
+ extendCompileEnvInt env k mb_gfo mo1b
_ -> do
let mos = modules gr
@@ -197,13 +200,21 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
if null warnings then return () else puts warnings $ return ()
intermOut opts DumpTypeCheck (ppModule Qualified mo3)
- (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3
- intermOut opts DumpRefresh (ppModule Qualified mo3r)
+ if flag optMode opts /= ModeTags
+ then do (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3
+ intermOut opts DumpRefresh (ppModule Qualified mo3r)
+
+ mo4 <- putpp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r
+ intermOut opts DumpOptimize (ppModule Qualified mo4)
- mo4 <- putpp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r
- intermOut opts DumpOptimize (ppModule Qualified mo4)
+ case mb_gfo of
+ Just gfo -> putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo mo4
+ Nothing -> return mo4
+
+ extendCompileEnvInt env k' mb_gfo mo4
+ else do putStrLnE ""
+ extendCompileEnvInt env k mb_gfo mo3
- return (k',mo4)
generateModuleCode :: Options -> FilePath -> SourceModule -> IOE SourceModule
generateModuleCode opts file minfo = do
diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index b3129128b..44e2e552b 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -112,14 +112,14 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
return $ updateTree (c,CncFun ty (Just def) pn) js
Ok (CncFun ty Nothing pn) ->
case mb_def of
- Ok def -> return $ updateTree (c,CncFun ty (Just (L (0,0) def)) pn) js
+ Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) pn) js
Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
return js
_ -> do
case mb_def of
Ok def -> do (cont,val) <- linTypeOfType gr cm ty
let linty = (snd (valCat ty),cont,val)
- return $ updateTree (c,CncFun (Just linty) (Just (L (0,0) def)) Nothing) js
+ return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing) js
Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
return js
AbsCat (Just _) -> case lookupIdent c js of
@@ -128,11 +128,11 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
Ok (CncCat _ mt mp) -> do
checkWarn $
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
- return $ updateTree (c,CncCat (Just (L (0,0) defLinType)) mt mp) js
+ return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) mt mp) js
_ -> do
checkWarn $
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
- return $ updateTree (c,CncCat (Just (L (0,0) defLinType)) Nothing Nothing) js
+ return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing) js
_ -> return js
checkCnc js i@(c,info) =
@@ -158,15 +158,15 @@ checkInfo ms (m,mo) c info = do
checkReservedId c
case info of
AbsCat (Just (L loc cont)) ->
- mkCheck loc "category" $
+ mkCheck loc "the category" $
checkContext gr cont
AbsFun (Just (L loc typ0)) ma md moper -> do
typ <- compAbsTyp [] typ0 -- to calculate let definitions
- mkCheck loc "type of function" $
+ mkCheck loc "the type of function" $
checkTyp gr typ
case md of
- Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "definition of function" $
+ Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
checkDef gr (m,c) typ eq) eqs
Nothing -> return ()
return (AbsFun (Just (L loc typ)) ma md moper)
@@ -204,7 +204,7 @@ checkInfo ms (m,mo) c info = do
checkError (text "No definition given to the operation")
return (ResOper pty' pde')
- ResOverload os tysts -> chIn (0,0) "overloading" $ do
+ ResOverload os tysts -> chIn NoLoc "overloading" $ do
tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones
tysts0 <- checkErr $ lookupOverload gr (m,c) -- check against inherited ones too
tysts1 <- mapM (uncurry $ flip (checkLType gr []))
@@ -215,17 +215,17 @@ checkInfo ms (m,mo) c info = do
sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
return (ResOverload os [(y,x) | (x,y) <- tysts'])
- ResParam (Just pcs) _ -> do
- ts <- liftM concat $ mapM mkPar pcs
- return (ResParam (Just pcs) (Just ts))
+ ResParam (Just (L loc pcs)) _ -> do
+ ts <- chIn loc "parameter type" $
+ liftM concat $ mapM mkPar pcs
+ return (ResParam (Just (L loc pcs)) (Just ts))
_ -> return info
where
gr = mGrammar ((m,mo) : ms)
- chIn loc cat = checkIn (text "Happened in" <+> text cat <+> ppIdent c <+> ppPosition m loc <> colon)
+ chIn loc cat = checkIn (ppLocation (msrc mo) loc <> colon $$ text "Happened in" <+> text cat <+> ppIdent c)
- mkPar (L loc (f,co)) =
- chIn loc "parameter type" $ do
+ mkPar (f,co) = do
vs <- checkErr $ liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
return $ map (mkApp (QC (m,f))) vs
@@ -238,7 +238,7 @@ checkInfo ms (m,mo) c info = do
mkCheck loc cat ss = case ss of
[] -> return info
- _ -> checkError (vcat ss $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition m loc)
+ _ -> checkError (ppLocation (msrc mo) loc <> colon $$ text "Happened in" <+> text cat <+> ppIdent c $$ nest 3 (vcat ss))
compAbsTyp g t = case t of
Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g
diff --git a/src/compiler/GF/Compile/Compute/AppPredefined.hs b/src/compiler/GF/Compile/Compute/AppPredefined.hs
index d15d57001..8732a8e06 100644
--- a/src/compiler/GF/Compile/Compute/AppPredefined.hs
+++ b/src/compiler/GF/Compile/Compute/AppPredefined.hs
@@ -46,14 +46,14 @@ arrityPredefined f = do ty <- typPredefined f
return (length ctxt)
predefModInfo :: SourceModInfo
-predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] primitives
+predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" primitives
primitives = Map.fromList
[ (cErrorType, ResOper (Just (noLoc typeType)) Nothing)
, (cInt , ResOper (Just (noLoc typePType)) Nothing)
, (cFloat , ResOper (Just (noLoc typePType)) Nothing)
, (cInts , fun [typeInt] typePType)
- , (cPBool , ResParam (Just [noLoc (cPTrue,[]),noLoc (cPFalse,[])]) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
+ , (cPBool , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
, (cPTrue , ResValue (noLoc typePBool))
, (cPFalse , ResValue (noLoc typePBool))
, (cError , fun [typeStr] typeError) -- non-can. of empty set
@@ -87,7 +87,7 @@ primitives = Map.fromList
fun from to = oper (mkFunType from to)
oper ty = ResOper (Just (noLoc ty)) Nothing
- noLoc = L (0,0)
+ noLoc = L NoLoc
varL :: Ident
varL = identC (BS.pack "L")
diff --git a/src/compiler/GF/Compile/GetGrammar.hs b/src/compiler/GF/Compile/GetGrammar.hs
index c7fea11b0..339f28578 100644
--- a/src/compiler/GF/Compile/GetGrammar.hs
+++ b/src/compiler/GF/Compile/GetGrammar.hs
@@ -41,9 +41,12 @@ getSourceModule opts file0 = ioe $
let location = file++":"++show l++":"++show c
return (Bad (location++": "++msg))
Right mo -> do removeTemp tmp
- return (Ok (addOptionsToModule opts mo))
+ return (Ok (addOptionsToModule opts (setSrcPath file0 mo)))
`catch` (return . Bad . show)
+setSrcPath :: FilePath -> SourceModule -> SourceModule
+setSrcPath fpath = mapSourceModule (\m -> m{msrc=fpath})
+
addOptionsToModule :: Options -> SourceModule -> SourceModule
addOptionsToModule opts = mapSourceModule (\m -> m { flags = flags m `addOptions` opts })
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index ed10697fd..81d2b3632 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -154,8 +154,8 @@ compilePatt eqs = whilePP eqs Map.empty
reorder :: Ident -> SourceGrammar -> AbsConcsGrammar
reorder abs cg =
-- M.MGrammar $
- ((abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs),
- [(cnc, M.ModInfo (M.MTConcrete abs) M.MSComplete cflags [] Nothing [] [] cdefs)
+ ((abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] "" adefs),
+ [(cnc, M.ModInfo (M.MTConcrete abs) M.MSComplete cflags [] Nothing [] [] "" cdefs)
| cnc <- M.allConcretes cg abs, let (cflags,cdefs) = concr cnc])
where
aflags =
@@ -165,7 +165,7 @@ reorder abs cg =
Map.fromList (predefADefs ++ Look.allOrigInfos cg abs)
where
predefADefs =
- [(c, AbsCat (Just (L (0,0) []))) | c <- [cFloat,cInt,cString]]
+ [(c, AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]]
concr la = (flags, Map.fromList (predefCDefs ++ jments))
where
@@ -173,4 +173,4 @@ reorder abs cg =
Just r <- [lookup i (M.allExtendSpecs cg la)]]
jments = Look.allOrigInfos cg la
predefCDefs =
- [(c, CncCat (Just (L (0,0) GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]]
+ [(c, CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]]
diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index 8cd84a1a0..4c959c194 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -47,24 +47,23 @@ import Text.PrettyPrint
-- | this gives top-level access to renaming term input in the cc command
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
renameSourceTerm g m t = do
- mo <- checkErr $ lookupModule g m
- status <- buildStatus g m mo
+ mi <- checkErr $ lookupModule g m
+ status <- buildStatus g m mi
renameTerm status [] t
-- | this gives top-level access to renaming term input in the cj command
renameSourceJudgement :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info)
renameSourceJudgement g m (i,t) = do
- mo <- checkErr $ lookupModule g m
- status <- buildStatus g m mo
- t2 <- renameInfo status m i t
+ mi <- checkErr $ lookupModule g m
+ status <- buildStatus g m mi
+ t2 <- renameInfo status (m,mi) i t
return (i,t2)
renameModule :: [SourceModule] -> SourceModule -> Check SourceModule
-renameModule ms (name,mo) = checkIn (text "renaming module" <+> ppIdent name) $ do
- let js1 = jments mo
- status <- buildStatus (mGrammar ms) name mo
- js2 <- checkMap (renameInfo status name) js1
- return (name, mo {opens = map forceQualif (opens mo), jments = js2})
+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{opens = map forceQualif (opens mi), jments = js})
type Status = (StatusTree, [(OpenSpec, StatusTree)])
@@ -147,15 +146,15 @@ forceQualif o = case o of
OSimple i -> OQualif i i
OQualif _ i -> OQualif i i
-renameInfo :: Status -> Ident -> Ident -> Info -> Check Info
-renameInfo status m i info =
+renameInfo :: Status -> SourceModule -> Ident -> Info -> Check Info
+renameInfo status (m,mi) i info =
case info of
AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco)
AbsFun pty pa ptr poper -> liftM4 AbsFun (renTerm pty) (return pa) (renMaybe (mapM (renLoc (renEquation status))) ptr) (return poper)
ResOper pty ptr -> liftM2 ResOper (renTerm pty) (renTerm ptr)
ResOverload os tysts -> liftM (ResOverload os) (mapM (renPair (renameTerm status [])) tysts)
ResParam (Just pp) m -> do
- pp' <- mapM (renLoc (renParam status)) pp
+ pp' <- renLoc (mapM (renParam status)) pp
return (ResParam (Just pp') m)
ResValue t -> do
t <- renLoc (renameTerm status []) t
@@ -172,7 +171,7 @@ renameInfo status m i info =
renMaybe ren Nothing = return Nothing
renLoc ren (L loc x) =
- checkIn (text "renaming of" <+> ppIdent i <+> ppPosition m loc) $ do
+ checkIn (ppLocation (msrc mi) loc <> colon $$ text "Happened in the renaming of" <+> ppIdent i) $ do
x <- ren x
return (L loc x)
diff --git a/src/compiler/GF/Compile/SubExOpt.hs b/src/compiler/GF/Compile/SubExOpt.hs
index 49d7efb81..808e4dca8 100644
--- a/src/compiler/GF/Compile/SubExOpt.hs
+++ b/src/compiler/GF/Compile/SubExOpt.hs
@@ -89,7 +89,7 @@ addSubexpConsts mo tree lins = do
list = Map.toList tree
- oper id trm = (operIdent id, ResOper (Just (L (0,0) (EInt 8))) (Just (L (0,0) trm)))
+ oper id trm = (operIdent id, ResOper (Just (L NoLoc (EInt 8))) (Just (L NoLoc trm)))
--- impossible type encoding generated opers
getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs
index 1dcae722c..fe9bd5984 100644
--- a/src/compiler/GF/Compile/Update.hs
+++ b/src/compiler/GF/Compile/Update.hs
@@ -63,7 +63,7 @@ extendModule gr (name,m)
let isCompl = isCompleteModule m0
-- build extension in a way depending on whether the old module is complete
- js1 <- extendMod gr isCompl (n, isInherited cond) name (jments m0) (jments mo)
+ js1 <- extendMod gr isCompl ((n,m0), isInherited cond) name (jments mo)
-- if incomplete, throw away extension information
return $
@@ -77,7 +77,7 @@ extendModule gr (name,m)
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003
rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule
-rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_)) = do
+rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ js_)) = do
---- deps <- moduleDeps ms
---- is <- openInterfaces deps i
let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005
@@ -92,7 +92,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_)) = do
MTInstance (i0,mincl) -> do
m1 <- lookupModule gr i0
testErr (isModRes m1) ("interface expected instead of" +++ showIdent i0)
- js' <- extendMod gr False (i0, isInherited mincl) i (jments m1) (jments mi)
+ js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi)
--- to avoid double inclusions, in instance I of I0 = J0 ** ...
case extends mi of
[] -> return $ replaceJudgements mi js'
@@ -110,7 +110,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_)) = do
[i | i <- is, notElem i infs]
testErr (stat' == MSComplete || stat == MSIncomplete)
("module" +++ showIdent i +++ "remains incomplete")
- ModInfo mt0 _ fs me' _ ops0 _ js <- lookupModule gr ext
+ ModInfo mt0 _ fs me' _ ops0 _ _ js <- lookupModule gr ext
let ops1 = nub $
ops_ ++ -- N.B. js has been name-resolved already
[OQualif i j | (i,j) <- ops] ++
@@ -123,7 +123,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_)) = do
let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
let js1 = buildTree (tree2list js_ ++ js0)
let med1= nub (ext : infs ++ insts ++ med_)
- return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 js1
+ return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 src_ js1
return (i,mi')
@@ -131,12 +131,11 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_)) = do
-- and the process is interrupted if unification fails.
-- If the extended module is incomplete, its judgements are just copied.
extendMod :: SourceGrammar ->
- Bool -> (Ident,Ident -> Bool) -> Ident ->
- BinTree Ident Info -> BinTree Ident Info ->
- Err (BinTree Ident Info)
-extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
+ Bool -> (SourceModule,Ident -> Bool) -> Ident ->
+ BinTree Ident Info -> Err (BinTree Ident Info)
+extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
where
- try new (c,i)
+ try new (c,i0)
| not (cond c) = return new
| otherwise = case Map.lookup c new of
Just j -> case unifyAnyInfo name i j of
@@ -155,6 +154,8 @@ extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
Nothing-> if isCompl
then return $ updateTree (c,indirInfo name i) new
else return $ updateTree (c,i) new
+ where
+ i = globalizeLoc (msrc mi) i0
indirInfo :: Ident -> Info -> Info
indirInfo n info = AnyInd b n' where
@@ -165,6 +166,24 @@ extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
AnyInd b k -> (b,k)
_ -> (False,n) ---- canonical in Abs
+globalizeLoc fpath i =
+ case i of
+ AbsCat mc -> AbsCat (fmap gl mc)
+ AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper
+ ResParam mt mv -> ResParam (fmap gl mt) mv
+ ResValue t -> ResValue (gl t)
+ ResOper mt m -> ResOper (fmap gl mt) (fmap gl m)
+ ResOverload ms os -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
+ CncCat mc mf mp -> CncCat (fmap gl mc) (fmap gl mf) (fmap gl mp)
+ CncFun m mt md -> CncFun m (fmap gl mt) (fmap gl md)
+ AnyInd b m -> AnyInd b m
+ where
+ gl (L loc0 x) = loc `seq` L (External fpath loc) x
+ where
+ loc = case loc0 of
+ External _ loc -> loc
+ loc -> loc
+
unifyAnyInfo :: Ident -> Info -> Info -> Err Info
unifyAnyInfo m i j = case (i,j) of
(AbsCat mc1, AbsCat mc2) ->
@@ -173,9 +192,9 @@ unifyAnyInfo m i j = case (i,j) of
liftM4 AbsFun (unifMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifMaybe moper1 moper2) -- adding defs
(ResParam mt1 mv1, ResParam mt2 mv2) ->
- liftM2 ResParam (unifMaybe mt1 mt2) (unifMaybe mv1 mv2)
- (ResValue t1, ResValue t2)
- | t1==t2 -> return (ResValue t1)
+ liftM2 ResParam (unifMaybeL mt1 mt2) (unifMaybe mv1 mv2)
+ (ResValue (L l1 t1), ResValue (L l2 t2))
+ | t1==t2 -> return (ResValue (L l1 t1))
| otherwise -> fail ""
(_, ResOverload ms t) | elem m ms ->
return $ ResOverload ms t
diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs
index 981037827..78ad3e53f 100644
--- a/src/compiler/GF/Grammar/Analyse.hs
+++ b/src/compiler/GF/Grammar/Analyse.hs
@@ -107,7 +107,7 @@ sizeInfo i = case i of
AbsFun mt mi me mb -> 1 + msize mt +
sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es]
ResParam mp mt ->
- 1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just ps <- [mp], L _ (_,co) <- ps]
+ 1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co) <- ps]
ResValue lt -> 0
ResOper mt md -> 1 + msize mt + msize md
ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]
diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs
index 32ddfe6ad..7c79be361 100644
--- a/src/compiler/GF/Grammar/Binary.hs
+++ b/src/compiler/GF/Grammar/Binary.hs
@@ -31,9 +31,9 @@ instance Binary a => Binary (MGrammar a) where
get = fmap mGrammar get
instance Binary a => Binary (ModInfo a) where
- put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,jments mi)
- get = do (mtype,mstatus,flags,extend,mwith,opens,med,jments) <- get
- return (ModInfo mtype mstatus flags extend mwith opens med jments)
+ put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,msrc mi,jments mi)
+ get = do (mtype,mstatus,flags,extend,mwith,opens,med,src,jments) <- get
+ return (ModInfo mtype mstatus flags extend mwith opens med src jments)
instance Binary ModuleType where
put MTAbstract = putWord8 0
@@ -109,6 +109,16 @@ instance Binary Info where
8 -> get >>= \(x,y) -> return (AnyInd x y)
_ -> decodingError
+instance Binary Location where
+ put NoLoc = putWord8 0
+ put (Local x y) = putWord8 1 >> put (x,y)
+ put (External x y) = putWord8 2 >> put (x,y)
+ get = do tag <- getWord8
+ case tag of
+ 0 -> return NoLoc
+ 1 -> get >>= \(x,y) -> return (Local x y)
+ 2 -> get >>= \(x,y) -> return (External x y)
+
instance Binary a => Binary (L a) where
put (L x y) = put (x,y)
get = get >>= \(x,y) -> return (L x y)
@@ -261,7 +271,7 @@ instance Binary Label where
decodeModHeader :: FilePath -> IO SourceModule
decodeModHeader fpath = do
- (m,mtype,mstatus,flags,extend,mwith,opens,med) <- decodeFile fpath
- return (m,ModInfo mtype mstatus flags extend mwith opens med Map.empty)
+ (m,mtype,mstatus,flags,extend,mwith,opens,med,src) <- decodeFile fpath
+ return (m,ModInfo mtype mstatus flags extend mwith opens med src Map.empty)
decodingError = fail "This GFO file was compiled with different version of GF"
diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs
index 93ae10b4a..10f7a71fd 100644
--- a/src/compiler/GF/Grammar/CF.hs
+++ b/src/compiler/GF/Grammar/CF.hs
@@ -19,15 +19,17 @@ import GF.Grammar.Macros
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Infra.Option
+import GF.Infra.UseIO
import GF.Data.Operations
import Data.Char
import Data.List
import qualified Data.ByteString.Char8 as BS
+import System.FilePath
-getCF :: String -> String -> Err SourceGrammar
-getCF name = fmap (cf2gf name) . pCF
+getCF :: FilePath -> String -> Err SourceGrammar
+getCF fpath = fmap (cf2gf fpath) . pCF
---------------------
-- the parser -------
@@ -50,9 +52,9 @@ getCFRule :: String -> Err [CFRule]
getCFRule s = getcf (wrds s) where
getcf ws = case ws of
fun : cat : a : its | isArrow a ->
- Ok [L (0,0) (init fun, (cat, map mkIt its))]
+ Ok [L NoLoc (init fun, (cat, map mkIt its))]
cat : a : its | isArrow a ->
- Ok [L (0,0) (mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
+ Ok [L NoLoc (mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
_ -> Bad (" invalid rule:" +++ s)
isArrow a = elem a ["->", "::="]
mkIt w = case w of
@@ -80,13 +82,14 @@ type CFFun = String
-- the compiler ----------
--------------------------
-cf2gf :: String -> CF -> SourceGrammar
-cf2gf name cf = mGrammar [
+cf2gf :: FilePath -> CF -> SourceGrammar
+cf2gf fpath cf = mGrammar [
(aname, addFlag (modifyFlags (\fs -> fs{optStartCat = Just cat}))
- (emptyModInfo{mtype = MTAbstract, jments = abs})),
- (cname, emptyModInfo{mtype = MTConcrete aname, jments = cnc})
+ (emptyModInfo{mtype = MTAbstract, msrc=fpath, jments = abs})),
+ (cname, emptyModInfo{mtype = MTConcrete aname, msrc=fpath, jments = cnc})
]
where
+ name = justModuleName fpath
(abs,cnc,cat) = cf2grammar cf
aname = identS $ name ++ "Abs"
cname = identS name
@@ -99,7 +102,7 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where
cat = case rules of
(L _ (_,(c,_))):_ -> c -- the value category of the first rule
_ -> error "empty CF"
- cats = [(cat, AbsCat (Just (L (0,0) []))) |
+ cats = [(cat, AbsCat (Just (L NoLoc []))) |
cat <- nub (concat (map cf2cat rules))] ----notPredef cat
lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
(funs,lins) = unzip (map cf2rule rules)
diff --git a/src/compiler/GF/Grammar/EBNF.hs b/src/compiler/GF/Grammar/EBNF.hs
index 11a2b3c4b..e5cbf6c7f 100644
--- a/src/compiler/GF/Grammar/EBNF.hs
+++ b/src/compiler/GF/Grammar/EBNF.hs
@@ -24,13 +24,14 @@ import GF.Grammar.Grammar
import Data.Char
import Data.List
+import System.FilePath
-- AR 18/4/2000 - 31/3/2004
-getEBNF :: String -> String -> Err SourceGrammar
-getEBNF name = fmap (cf2gf name . ebnf2cf) . pEBNF
+getEBNF :: FilePath -> String -> Err SourceGrammar
+getEBNF fpath = fmap (cf2gf fpath . ebnf2cf) . pEBNF
type EBNF = [ERule]
type ERule = (ECat, ERHS)
@@ -54,7 +55,7 @@ type CFJustRule = (CFCat, CFRHS)
ebnf2cf :: EBNF -> [CFRule]
ebnf2cf ebnf =
- [L (0,0) (mkCFF i rule,rule) | (i,rule) <- zip [0..] (normEBNF ebnf)] where
+ [L NoLoc (mkCFF i rule,rule) | (i,rule) <- zip [0..] (normEBNF ebnf)] where
mkCFF i (c, _) = ("Mk" ++ c ++ "_" ++ show i)
normEBNF :: EBNF -> [CFJustRule]
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index ae29ab6d5..627355033 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -20,7 +20,7 @@ module GF.Grammar.Grammar (SourceGrammar,
SourceModule,
mapSourceModule,
Info(..),
- L(..), unLoc,
+ Location(..), L(..), unLoc,
Type,
Cat,
Fun,
@@ -80,7 +80,7 @@ data Info =
| AbsFun (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) (Maybe Bool) -- ^ (/ABS/) type, arrity and definition of a function
-- judgements in resource
- | ResParam (Maybe [L Param]) (Maybe [Term]) -- ^ (/RES/) the second parameter is list of all possible values
+ | ResParam (Maybe (L [Param])) (Maybe [Term]) -- ^ (/RES/) the second parameter is list of all possible values
| ResValue (L Type) -- ^ (/RES/) to mark parameter constructors for lookup
| ResOper (Maybe (L Type)) (Maybe (L Term)) -- ^ (/RES/)
@@ -94,8 +94,14 @@ data Info =
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
deriving Show
-data L a = L (Int,Int) a -- location information
- deriving (Eq,Show)
+data Location
+ = NoLoc
+ | Local Int Int
+ | External FilePath Location
+ deriving (Show,Eq,Ord)
+
+data L a = L Location a -- location information
+ deriving Show
instance Functor L where
fmap f (L loc x) = L loc (f x)
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index 435280963..651fde4d0 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -191,7 +191,7 @@ lookupCatContext gr m c = do
-- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations
-- notice that it only gives the modules that are reachable and the opers that are included
-allOpers :: SourceGrammar -> [((Ident,Ident),Type,(Int,Int))]
+allOpers :: SourceGrammar -> [((Ident,Ident),Type,Location)]
allOpers gr =
[((mo,op),typ,loc) |
(mo,minc) <- reachable,
@@ -212,7 +212,7 @@ allOpers gr =
_ -> []
--- not for dependent types
-allOpersTo :: SourceGrammar -> Type -> [((Ident,Ident),Type,(Int,Int))]
+allOpersTo :: SourceGrammar -> Type -> [((Ident,Ident),Type,Location)]
allOpersTo gr ty = [op | op@(_,typ,_) <- allOpers gr, isProdTo ty typ] where
isProdTo t typ = eqProd typ t || case typ of
Prod _ _ a b -> isProdTo t b
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index 30795cecb..38b22aaa2 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -560,7 +560,7 @@ allDependencies ism b =
pts i = case i of
ResOper pty pt -> [pty,pt]
ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
- ResParam (Just ps) _ -> [Just (L loc t) | L loc (_,cont) <- ps, (_,_,t) <- cont]
+ ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
CncCat pty _ _ -> [pty]
CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type))
AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual
diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y
index 23974f6b1..26b7e123b 100644
--- a/src/compiler/GF/Grammar/Parser.y
+++ b/src/compiler/GF/Grammar/Parser.y
@@ -5,7 +5,7 @@ module GF.Grammar.Parser
, pModDef
, pModHeader
, pExp
- , pTopDef
+ , pTopDef
) where
import GF.Infra.Ident
@@ -118,14 +118,14 @@ ModDef
defs <- case buildAnyTree id jments of
Ok x -> return x
Bad msg -> fail msg
- return (id, ModInfo mtype mstat opts extends with opens [] defs) }
+ return (id, ModInfo mtype mstat opts extends with opens [] "" defs) }
ModHeader :: { SourceModule }
ModHeader
: ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
(mtype,id) = $2 ;
(extends,with,opens) = $4 }
- in (id, ModInfo mtype mstat noOptions extends with opens [] emptyBinTree) }
+ in (id, ModInfo mtype mstat noOptions extends with opens [] "" emptyBinTree) }
ComplMod :: { ModuleStatus }
ComplMod
@@ -251,9 +251,9 @@ DataDef
ParamDef :: { [(Ident,Info)] }
ParamDef
- : Ident '=' ListParConstr { ($1, ResParam (Just $3) Nothing) :
- [(f, ResValue (L loc (mkProdSimple co (Cn $1)))) | L loc (f,co) <- $3] }
- | Ident { [($1, ResParam Nothing Nothing)] }
+ : Posn Ident '=' ListParConstr Posn { ($2, ResParam (Just (mkL $1 $5 [param | L loc param <- $4])) Nothing) :
+ [(f, ResValue (L loc (mkProdSimple co (Cn $2)))) | L loc (f,co) <- $4] }
+ | Posn Ident Posn { [($2, ResParam Nothing Nothing)] }
OperDef :: { [(Ident,Info)] }
OperDef
@@ -679,7 +679,7 @@ checkInfoType mt jment@(id,info) =
AbsFun pty _ pde _ -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
CncCat pty pd ppn -> ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh ppn)
CncFun _ pd ppn -> ifConcrete mt (locPerh pd ++ locPerh ppn)
- ResParam pparam _ -> ifResource mt (maybe [] locAll pparam)
+ ResParam pparam _ -> ifResource mt (locPerh pparam)
ResValue ty -> ifResource mt (locL ty)
ResOper pty pt -> ifOper mt pty pt
ResOverload _ xs -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
@@ -688,8 +688,8 @@ checkInfoType mt jment@(id,info) =
locAll xs = [loc | L loc x <- xs]
locL (L loc x) = [loc]
- illegal ((s,e):_) = failLoc (Pn s 0) "illegal definition"
- illegal _ = return jment
+ illegal (Local s e:_) = failLoc (Pn s 0) "illegal definition"
+ illegal _ = return jment
ifAbstract MTAbstract locs = return jment
ifAbstract _ locs = illegal locs
@@ -729,6 +729,6 @@ mkAlts cs = case cs of
_ -> fail "no strs from pattern"
mkL :: Posn -> Posn -> x -> L x
-mkL (Pn l1 _) (Pn l2 _) x = L (l1,l2) x
+mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) x
}
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index 5fa9121fc..ce8562db7 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -17,7 +17,7 @@ module GF.Grammar.Printer
, ppPatt
, ppValue
, ppConstrs
- , ppPosition
+ , ppLocation
, ppQIdent
) where
@@ -38,7 +38,7 @@ ppGrammar :: SourceGrammar -> Doc
ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr
ppModule :: TermPrintQual -> SourceModule -> Doc
-ppModule q (mn, ModInfo mtype mstat opts exts with opens _ jments) =
+ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) =
hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr
where
defs = Map.toList jments
@@ -97,8 +97,8 @@ ppJudgement q (id, AbsFun ptype _ pexp poper) =
ppJudgement q (id, ResParam pparams _) =
text "param" <+> ppIdent id <+>
(case pparams of
- Just ps -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps))
- _ -> empty) <+> semi
+ Just (L _ ps) -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps))
+ _ -> empty) <+> semi
ppJudgement q (id, ResValue pvalue) = empty
ppJudgement q (id, ResOper ptype pexp) =
text "oper" <+> ppIdent id <+>
@@ -269,12 +269,14 @@ ppBind (Implicit,v) = braces (ppIdent v)
ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y
-ppParam q (L _ (id,cxt)) = ppIdent id <+> hsep (map (ppDDecl q) cxt)
+ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt)
-ppPosition :: Ident -> (Int,Int) -> Doc
-ppPosition m (b,e)
- | b == e = text "in" <+> ppIdent m <> text ".gf, line" <+> int b
- | otherwise = text "in" <+> ppIdent m <> text ".gf, lines" <+> int b <> text "-" <> int e
+ppLocation :: FilePath -> Location -> Doc
+ppLocation fpath NoLoc = text fpath
+ppLocation fpath (External p l) = ppLocation p l
+ppLocation fpath (Local b e)
+ | b == e = text fpath <> colon <> int b
+ | otherwise = text fpath <> colon <> int b <> text "-" <> int e
commaPunct f ds = (hcat (punctuate comma (map f ds)))
diff --git a/src/compiler/GF/Infra/Modules.hs b/src/compiler/GF/Infra/Modules.hs
index a80c0060a..67e010ece 100644
--- a/src/compiler/GF/Infra/Modules.hs
+++ b/src/compiler/GF/Infra/Modules.hs
@@ -46,16 +46,11 @@ import GF.Data.Operations
import Data.List
import qualified Data.Map as Map
import Text.PrettyPrint
+import System.FilePath
--- AR 29/4/2003
--- The same structure will be used in both source code and canonical.
--- The parameters tell what kind of data is involved.
-- Invariant: modules are stored in dependency order
---mGrammar = MGrammar
---newtype MGrammar a = MGrammar {modules :: [(Ident,ModInfo a)]}
-
data MGrammar a = MGrammar { moduleMap :: Map.Map Ident (ModInfo a),
modules :: [(Ident,ModInfo a)] }
deriving Show
@@ -69,6 +64,7 @@ data ModInfo a = ModInfo {
mwith :: Maybe (Ident,MInclude,[(Ident,Ident)]),
opens :: [OpenSpec],
mexdeps :: [Ident],
+ msrc :: FilePath,
jments :: Map.Map Ident a
}
deriving Show
@@ -109,13 +105,13 @@ updateMGrammar (MGrammar omap os) (MGrammar nmap ns) =
nis = map fst ns
-}
updateModule :: ModInfo t -> Ident -> t -> ModInfo t
-updateModule (ModInfo mt ms fs me mw ops med js) i t = ModInfo mt ms fs me mw ops med (updateTree (i,t) js)
+updateModule (ModInfo mt ms fs me mw ops med src js) i t = ModInfo mt ms fs me mw ops med src (updateTree (i,t) js)
replaceJudgements :: ModInfo t -> Map.Map Ident t -> ModInfo t
-replaceJudgements (ModInfo mt ms fs me mw ops med _) js = ModInfo mt ms fs me mw ops med js
+replaceJudgements (ModInfo mt ms fs me mw ops med src _) js = ModInfo mt ms fs me mw ops med src js
addOpenQualif :: Ident -> Ident -> ModInfo t -> ModInfo t
-addOpenQualif i j (ModInfo mt ms fs me mw ops med js) = ModInfo mt ms fs me mw (OQualif i j : ops) med js
+addOpenQualif i j (ModInfo mt ms fs me mw ops med src js) = ModInfo mt ms fs me mw (OQualif i j : ops) med src js
addFlag :: Options -> ModInfo t -> ModInfo t
addFlag f mo = mo {flags = flags mo `addOptions` f}
@@ -227,7 +223,7 @@ emptyMGrammar :: MGrammar a
emptyMGrammar = mGrammar []
emptyModInfo :: ModInfo a
-emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree
+emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "" emptyBinTree
-- | we store the module type with the identifier
diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index 27594f57f..b238de3cb 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -74,7 +74,7 @@ errors = fail . unlines
-- Types
data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeRun | ModeCompiler
- | ModeServer
+ | ModeServer | ModeTags
deriving (Show,Eq,Ord)
data Verbosity = Quiet | Normal | Verbose | Debug
@@ -299,6 +299,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 ['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) .",
diff --git a/src/compiler/GFTags.hs b/src/compiler/GFTags.hs
new file mode 100644
index 000000000..7e56f9a4f
--- /dev/null
+++ b/src/compiler/GFTags.hs
@@ -0,0 +1,51 @@
+module GFTags where
+
+import GF.Infra.Option
+import GF.Infra.Modules
+import GF.Infra.UseIO
+import GF.Grammar
+import GF.Compile
+
+import Data.List
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Control.Monad
+import Text.PrettyPrint
+
+mainTags opts files = do
+ gr <- batchCompile opts files
+ let tags = foldl getTags [] (modules gr)
+ ioeIO (writeFile "tags" (unlines ((Set.toList . Set.fromList) tags)))
+
+getTags 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 mb_type mb_def mb_prn) = maybe (loc "lincat") mb_type ++
+ maybe (loc "lindef") mb_def ++
+ maybe (loc "printname") mb_prn
+ getLocations (CncFun _ mb_lin mb_prn) = maybe (loc "lin") mb_lin ++
+ maybe (loc "printname") mb_prn
+ 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}
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 05:39:51 +0000