GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 19:42:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

Now the compiler maintains more precise information for the source locations of the different definitions. There is a --tags option which generates a list of all identifiers with their source locations.

Browse Source
This commit is contained in:
kr.angelov
2011-11-02 11:44:59 +00:00
parent 42af63414f
commit 5fe49ed9f7
22 changed files with 232 additions and 129 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/compiler/GF.hs
View File

@@ -3,6 +3,7 @@ module Main where
import GFC import GFC
import GFI import GFI
import GFTags
import GF.Data.ErrM import GF.Data.ErrM
import GF.Infra.Option import GF.Infra.Option
import GF.Infra.UseIO import GF.Infra.UseIO
@@ -47,3 +48,4 @@ mainOpts opts files =
ModeRun -> mainRunGFI opts files ModeRun -> mainRunGFI opts files
ModeServer -> mainServerGFI opts files ModeServer -> mainServerGFI opts files
ModeCompiler -> dieIOE (mainGFC opts files) ModeCompiler -> dieIOE (mainGFC opts files)
ModeTags -> dieIOE (mainTags opts files)

9
src/compiler/GF/Command/Importing.hs
View File

@@ -55,12 +55,11 @@ importSource src0 opts files = do
-- for different cf formats -- for different cf formats
importCF opts files get = do importCF opts files get = do
s <- fmap unlines $ mapM readFile files s <- fmap unlines $ mapM readFile files
let cnc = justModuleName (last files) gf <- case get (last files) s of
gf <- case get cnc s of Ok gf -> return gf
Ok g -> return g
Bad s -> error s ---- Bad s -> error s ----
Ok gr <- appIOE $ compileSourceGrammar opts gf 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 case epgf of
Ok pgf -> return pgf Ok pgf -> return pgf
Bad s -> error s ---- Bad s -> error s ----

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

@@ -70,12 +70,11 @@ batchCompile opts files = do
-- to compile a set of modules, e.g. an old GF or a .cf file -- to compile a set of modules, e.g. an old GF or a .cf file
compileSourceGrammar :: Options -> SourceGrammar -> IOE SourceGrammar compileSourceGrammar :: Options -> SourceGrammar -> IOE SourceGrammar
compileSourceGrammar opts gr = do 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' 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 -- to output an intermediate stage
intermOut :: Options -> Dump -> Doc -> IOE () intermOut :: Options -> Dump -> Doc -> IOE ()
@@ -161,18 +160,16 @@ compileOne opts env@(_,srcgr,_) file = do
sm00 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ sm00 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $
getSourceModule opts file getSourceModule opts file
enc <- ioeIO $ mkTextEncoding (renameEncoding (flag optEncoding (flagsModule sm00))) 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 compileSourceModule opts env (Just gfo) sm
putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo sm
extendCompileEnvInt env k' (Just gfo) sm
where where
isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete
compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule) compileSourceModule :: Options -> CompileEnv -> Maybe FilePath -> SourceModule -> IOE CompileEnv
compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do compileSourceModule opts env@(k,gr,_) mb_gfo mo@(i,mi) = do
let puts = putPointE Quiet opts let puts = putPointE Quiet opts
putpp = putPointE Verbose opts putpp = putPointE Verbose opts
@@ -185,7 +182,13 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
case mo1b of case mo1b of
(_,n) | not (isCompleteModule n) -> do (_,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 _ -> do
let mos = modules gr 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 () if null warnings then return () else puts warnings $ return ()
intermOut opts DumpTypeCheck (ppModule Qualified mo3) intermOut opts DumpTypeCheck (ppModule Qualified mo3)
(k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 if flag optMode opts /= ModeTags
intermOut opts DumpRefresh (ppModule Qualified mo3r) 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 mo4 <- putpp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r
intermOut opts DumpOptimize (ppModule Qualified mo4) 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 :: Options -> FilePath -> SourceModule -> IOE SourceModule
generateModuleCode opts file minfo = do generateModuleCode opts file minfo = do

30
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -112,14 +112,14 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
return $ updateTree (c,CncFun ty (Just def) pn) js return $ updateTree (c,CncFun ty (Just def) pn) js
Ok (CncFun ty Nothing pn) -> Ok (CncFun ty Nothing pn) ->
case mb_def of 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 Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
return js return js
_ -> do _ -> do
case mb_def of case mb_def of
Ok def -> do (cont,val) <- linTypeOfType gr cm ty Ok def -> do (cont,val) <- linTypeOfType gr cm ty
let linty = (snd (valCat ty),cont,val) 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 Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
return js return js
AbsCat (Just _) -> case lookupIdent c js of AbsCat (Just _) -> case lookupIdent c js of
@@ -128,11 +128,11 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
Ok (CncCat _ mt mp) -> do Ok (CncCat _ mt mp) -> do
checkWarn $ checkWarn $
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}" 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 _ -> do
checkWarn $ checkWarn $
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}" 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 _ -> return js
checkCnc js i@(c,info) = checkCnc js i@(c,info) =
@@ -158,15 +158,15 @@ checkInfo ms (m,mo) c info = do
checkReservedId c checkReservedId c
case info of case info of
AbsCat (Just (L loc cont)) -> AbsCat (Just (L loc cont)) ->
mkCheck loc "category" $ mkCheck loc "the category" $
checkContext gr cont checkContext gr cont
AbsFun (Just (L loc typ0)) ma md moper -> do AbsFun (Just (L loc typ0)) ma md moper -> do
typ <- compAbsTyp [] typ0 -- to calculate let definitions typ <- compAbsTyp [] typ0 -- to calculate let definitions
mkCheck loc "type of function" $ mkCheck loc "the type of function" $
checkTyp gr typ checkTyp gr typ
case md of 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 checkDef gr (m,c) typ eq) eqs
Nothing -> return () Nothing -> return ()
return (AbsFun (Just (L loc typ)) ma md moper) 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") checkError (text "No definition given to the operation")
return (ResOper pty' pde') 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 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 tysts0 <- checkErr $ lookupOverload gr (m,c) -- check against inherited ones too
tysts1 <- mapM (uncurry $ flip (checkLType gr [])) 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] sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
return (ResOverload os [(y,x) | (x,y) <- tysts']) return (ResOverload os [(y,x) | (x,y) <- tysts'])
ResParam (Just pcs) _ -> do ResParam (Just (L loc pcs)) _ -> do
ts <- liftM concat $ mapM mkPar pcs ts <- chIn loc "parameter type" $
return (ResParam (Just pcs) (Just ts)) liftM concat $ mapM mkPar pcs
return (ResParam (Just (L loc pcs)) (Just ts))
_ -> return info _ -> return info
where where
gr = mGrammar ((m,mo) : ms) 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)) = mkPar (f,co) = do
chIn loc "parameter type" $ do
vs <- checkErr $ liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co vs <- checkErr $ liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
return $ map (mkApp (QC (m,f))) vs 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 mkCheck loc cat ss = case ss of
[] -> return info [] -> 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 compAbsTyp g t = case t of
Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g

6
src/compiler/GF/Compile/Compute/AppPredefined.hs
View File

@@ -46,14 +46,14 @@ arrityPredefined f = do ty <- typPredefined f
return (length ctxt) return (length ctxt)
predefModInfo :: SourceModInfo predefModInfo :: SourceModInfo
predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] primitives predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" primitives
primitives = Map.fromList primitives = Map.fromList
[ (cErrorType, ResOper (Just (noLoc typeType)) Nothing) [ (cErrorType, ResOper (Just (noLoc typeType)) Nothing)
, (cInt , ResOper (Just (noLoc typePType)) Nothing) , (cInt , ResOper (Just (noLoc typePType)) Nothing)
, (cFloat , ResOper (Just (noLoc typePType)) Nothing) , (cFloat , ResOper (Just (noLoc typePType)) Nothing)
, (cInts , fun [typeInt] typePType) , (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)) , (cPTrue , ResValue (noLoc typePBool))
, (cPFalse , ResValue (noLoc typePBool)) , (cPFalse , ResValue (noLoc typePBool))
, (cError , fun [typeStr] typeError) -- non-can. of empty set , (cError , fun [typeStr] typeError) -- non-can. of empty set
@@ -87,7 +87,7 @@ primitives = Map.fromList
fun from to = oper (mkFunType from to) fun from to = oper (mkFunType from to)
oper ty = ResOper (Just (noLoc ty)) Nothing oper ty = ResOper (Just (noLoc ty)) Nothing
noLoc = L (0,0) noLoc = L NoLoc
varL :: Ident varL :: Ident
varL = identC (BS.pack "L") varL = identC (BS.pack "L")

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

@@ -41,9 +41,12 @@ getSourceModule opts file0 = ioe $
let location = file++":"++show l++":"++show c let location = file++":"++show l++":"++show c
return (Bad (location++": "++msg)) return (Bad (location++": "++msg))
Right mo -> do removeTemp tmp Right mo -> do removeTemp tmp
return (Ok (addOptionsToModule opts mo)) return (Ok (addOptionsToModule opts (setSrcPath file0 mo)))
`catch` (return . Bad . show) `catch` (return . Bad . show)
setSrcPath :: FilePath -> SourceModule -> SourceModule
setSrcPath fpath = mapSourceModule (\m -> m{msrc=fpath})
addOptionsToModule :: Options -> SourceModule -> SourceModule addOptionsToModule :: Options -> SourceModule -> SourceModule
addOptionsToModule opts = mapSourceModule (\m -> m { flags = flags m `addOptions` opts }) addOptionsToModule opts = mapSourceModule (\m -> m { flags = flags m `addOptions` opts })

8
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -154,8 +154,8 @@ compilePatt eqs = whilePP eqs Map.empty
reorder :: Ident -> SourceGrammar -> AbsConcsGrammar reorder :: Ident -> SourceGrammar -> AbsConcsGrammar
reorder abs cg = reorder abs cg =
-- M.MGrammar $ -- M.MGrammar $
((abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs), ((abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] "" adefs),
[(cnc, M.ModInfo (M.MTConcrete abs) M.MSComplete cflags [] Nothing [] [] cdefs) [(cnc, M.ModInfo (M.MTConcrete abs) M.MSComplete cflags [] Nothing [] [] "" cdefs)
| cnc <- M.allConcretes cg abs, let (cflags,cdefs) = concr cnc]) | cnc <- M.allConcretes cg abs, let (cflags,cdefs) = concr cnc])
where where
aflags = aflags =
@@ -165,7 +165,7 @@ reorder abs cg =
Map.fromList (predefADefs ++ Look.allOrigInfos cg abs) Map.fromList (predefADefs ++ Look.allOrigInfos cg abs)
where where
predefADefs = 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)) concr la = (flags, Map.fromList (predefCDefs ++ jments))
where where
@@ -173,4 +173,4 @@ reorder abs cg =
Just r <- [lookup i (M.allExtendSpecs cg la)]] Just r <- [lookup i (M.allExtendSpecs cg la)]]
jments = Look.allOrigInfos cg la jments = Look.allOrigInfos cg la
predefCDefs = 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]]

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

@@ -47,24 +47,23 @@ import Text.PrettyPrint
-- | this gives top-level access to renaming term input in the cc command -- | this gives top-level access to renaming term input in the cc command
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
renameSourceTerm g m t = do renameSourceTerm g m t = do
mo <- checkErr $ lookupModule g m mi <- checkErr $ lookupModule g m
status <- buildStatus g m mo status <- buildStatus g m mi
renameTerm status [] t renameTerm status [] t
-- | this gives top-level access to renaming term input in the cj command -- | this gives top-level access to renaming term input in the cj command
renameSourceJudgement :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) renameSourceJudgement :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info)
renameSourceJudgement g m (i,t) = do renameSourceJudgement g m (i,t) = do
mo <- checkErr $ lookupModule g m mi <- checkErr $ lookupModule g m
status <- buildStatus g m mo status <- buildStatus g m mi
t2 <- renameInfo status m i t t2 <- renameInfo status (m,mi) i t
return (i,t2) return (i,t2)
renameModule :: [SourceModule] -> SourceModule -> Check SourceModule renameModule :: [SourceModule] -> SourceModule -> Check SourceModule
renameModule ms (name,mo) = checkIn (text "renaming module" <+> ppIdent name) $ do renameModule ms mo@(m,mi) = checkIn (text "renaming module" <+> ppIdent m) $ do
let js1 = jments mo status <- buildStatus (mGrammar ms) m mi
status <- buildStatus (mGrammar ms) name mo js <- checkMap (renameInfo status mo) (jments mi)
js2 <- checkMap (renameInfo status name) js1 return (m, mi{opens = map forceQualif (opens mi), jments = js})
return (name, mo {opens = map forceQualif (opens mo), jments = js2})
type Status = (StatusTree, [(OpenSpec, StatusTree)]) type Status = (StatusTree, [(OpenSpec, StatusTree)])
@@ -147,15 +146,15 @@ forceQualif o = case o of
OSimple i -> OQualif i i OSimple i -> OQualif i i
OQualif _ i -> OQualif i i OQualif _ i -> OQualif i i
renameInfo :: Status -> Ident -> Ident -> Info -> Check Info renameInfo :: Status -> SourceModule -> Ident -> Info -> Check Info
renameInfo status m i info = renameInfo status (m,mi) i info =
case info of case info of
AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco) 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) 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) ResOper pty ptr -> liftM2 ResOper (renTerm pty) (renTerm ptr)
ResOverload os tysts -> liftM (ResOverload os) (mapM (renPair (renameTerm status [])) tysts) ResOverload os tysts -> liftM (ResOverload os) (mapM (renPair (renameTerm status [])) tysts)
ResParam (Just pp) m -> do ResParam (Just pp) m -> do
pp' <- mapM (renLoc (renParam status)) pp pp' <- renLoc (mapM (renParam status)) pp
return (ResParam (Just pp') m) return (ResParam (Just pp') m)
ResValue t -> do ResValue t -> do
t <- renLoc (renameTerm status []) t t <- renLoc (renameTerm status []) t
@@ -172,7 +171,7 @@ renameInfo status m i info =
renMaybe ren Nothing = return Nothing renMaybe ren Nothing = return Nothing
renLoc ren (L loc x) = 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 x <- ren x
return (L loc x) return (L loc x)

2
src/compiler/GF/Compile/SubExOpt.hs
View File

@@ -89,7 +89,7 @@ addSubexpConsts mo tree lins = do
list = Map.toList tree 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 --- impossible type encoding generated opers
getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int)) getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int))

45
src/compiler/GF/Compile/Update.hs
View File

@@ -63,7 +63,7 @@ extendModule gr (name,m)
let isCompl = isCompleteModule m0 let isCompl = isCompleteModule m0
-- build extension in a way depending on whether the old module is complete -- 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 -- if incomplete, throw away extension information
return $ return $
@@ -77,7 +77,7 @@ extendModule gr (name,m)
-- | rebuilding instance + interface, and "with" modules, prior to renaming. -- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003 -- AR 24/10/2003
rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule 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 ---- deps <- moduleDeps ms
---- is <- openInterfaces deps i ---- is <- openInterfaces deps i
let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005 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 MTInstance (i0,mincl) -> do
m1 <- lookupModule gr i0 m1 <- lookupModule gr i0
testErr (isModRes m1) ("interface expected instead of" +++ showIdent 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 ** ... --- to avoid double inclusions, in instance I of I0 = J0 ** ...
case extends mi of case extends mi of
[] -> return $ replaceJudgements mi js' [] -> 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] [i | i <- is, notElem i infs]
testErr (stat' == MSComplete || stat == MSIncomplete) testErr (stat' == MSComplete || stat == MSIncomplete)
("module" +++ showIdent i +++ "remains incomplete") ("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 $ let ops1 = nub $
ops_ ++ -- N.B. js has been name-resolved already ops_ ++ -- N.B. js has been name-resolved already
[OQualif i j | (i,j) <- ops] ++ [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 js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
let js1 = buildTree (tree2list js_ ++ js0) let js1 = buildTree (tree2list js_ ++ js0)
let med1= nub (ext : infs ++ insts ++ med_) 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') 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. -- and the process is interrupted if unification fails.
-- If the extended module is incomplete, its judgements are just copied. -- If the extended module is incomplete, its judgements are just copied.
extendMod :: SourceGrammar -> extendMod :: SourceGrammar ->
Bool -> (Ident,Ident -> Bool) -> Ident -> Bool -> (SourceModule,Ident -> Bool) -> Ident ->
BinTree Ident Info -> BinTree Ident Info -> BinTree Ident Info -> Err (BinTree Ident Info)
Err (BinTree Ident Info) extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
where where
try new (c,i) try new (c,i0)
| not (cond c) = return new | not (cond c) = return new
| otherwise = case Map.lookup c new of | otherwise = case Map.lookup c new of
Just j -> case unifyAnyInfo name i j 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 Nothing-> if isCompl
then return $ updateTree (c,indirInfo name i) new then return $ updateTree (c,indirInfo name i) new
else return $ updateTree (c,i) new else return $ updateTree (c,i) new
where
i = globalizeLoc (msrc mi) i0
indirInfo :: Ident -> Info -> Info indirInfo :: Ident -> Info -> Info
indirInfo n info = AnyInd b n' where 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) AnyInd b k -> (b,k)
_ -> (False,n) ---- canonical in Abs _ -> (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 :: Ident -> Info -> Info -> Err Info
unifyAnyInfo m i j = case (i,j) of unifyAnyInfo m i j = case (i,j) of
(AbsCat mc1, AbsCat mc2) -> (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 liftM4 AbsFun (unifMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifMaybe moper1 moper2) -- adding defs
(ResParam mt1 mv1, ResParam mt2 mv2) -> (ResParam mt1 mv1, ResParam mt2 mv2) ->
liftM2 ResParam (unifMaybe mt1 mt2) (unifMaybe mv1 mv2) liftM2 ResParam (unifMaybeL mt1 mt2) (unifMaybe mv1 mv2)
(ResValue t1, ResValue t2) (ResValue (L l1 t1), ResValue (L l2 t2))
| t1==t2 -> return (ResValue t1) | t1==t2 -> return (ResValue (L l1 t1))
| otherwise -> fail "" | otherwise -> fail ""
(_, ResOverload ms t) | elem m ms -> (_, ResOverload ms t) | elem m ms ->
return $ ResOverload ms t return $ ResOverload ms t

2
src/compiler/GF/Grammar/Analyse.hs
View File

@@ -107,7 +107,7 @@ sizeInfo i = case i of
AbsFun mt mi me mb -> 1 + msize mt + AbsFun mt mi me mb -> 1 + msize mt +
sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es] sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es]
ResParam mp mt -> 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 ResValue lt -> 0
ResOper mt md -> 1 + msize mt + msize md ResOper mt md -> 1 + msize mt + msize md
ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs] ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]

20
src/compiler/GF/Grammar/Binary.hs
View File

@@ -31,9 +31,9 @@ instance Binary a => Binary (MGrammar a) where
get = fmap mGrammar get get = fmap mGrammar get
instance Binary a => Binary (ModInfo a) where 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) 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,jments) <- get get = do (mtype,mstatus,flags,extend,mwith,opens,med,src,jments) <- get
return (ModInfo mtype mstatus flags extend mwith opens med jments) return (ModInfo mtype mstatus flags extend mwith opens med src jments)
instance Binary ModuleType where instance Binary ModuleType where
put MTAbstract = putWord8 0 put MTAbstract = putWord8 0
@@ -109,6 +109,16 @@ instance Binary Info where
8 -> get >>= \(x,y) -> return (AnyInd x y) 8 -> get >>= \(x,y) -> return (AnyInd x y)
_ -> decodingError _ -> 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 instance Binary a => Binary (L a) where
put (L x y) = put (x,y) put (L x y) = put (x,y)
get = get >>= \(x,y) -> return (L x y) get = get >>= \(x,y) -> return (L x y)
@@ -261,7 +271,7 @@ instance Binary Label where
decodeModHeader :: FilePath -> IO SourceModule decodeModHeader :: FilePath -> IO SourceModule
decodeModHeader fpath = do decodeModHeader fpath = do
(m,mtype,mstatus,flags,extend,mwith,opens,med) <- decodeFile fpath (m,mtype,mstatus,flags,extend,mwith,opens,med,src) <- decodeFile fpath
return (m,ModInfo mtype mstatus flags extend mwith opens med Map.empty) 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" decodingError = fail "This GFO file was compiled with different version of GF"

21
src/compiler/GF/Grammar/CF.hs
View File

@@ -19,15 +19,17 @@ import GF.Grammar.Macros
import GF.Infra.Ident import GF.Infra.Ident
import GF.Infra.Modules import GF.Infra.Modules
import GF.Infra.Option import GF.Infra.Option
import GF.Infra.UseIO
import GF.Data.Operations import GF.Data.Operations
import Data.Char import Data.Char
import Data.List import Data.List
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import System.FilePath
getCF :: String -> String -> Err SourceGrammar getCF :: FilePath -> String -> Err SourceGrammar
getCF name = fmap (cf2gf name) . pCF getCF fpath = fmap (cf2gf fpath) . pCF
--------------------- ---------------------
-- the parser ------- -- the parser -------
@@ -50,9 +52,9 @@ getCFRule :: String -> Err [CFRule]
getCFRule s = getcf (wrds s) where getCFRule s = getcf (wrds s) where
getcf ws = case ws of getcf ws = case ws of
fun : cat : a : its | isArrow a -> 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 -> 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) _ -> Bad (" invalid rule:" +++ s)
isArrow a = elem a ["->", "::="] isArrow a = elem a ["->", "::="]
mkIt w = case w of mkIt w = case w of
@@ -80,13 +82,14 @@ type CFFun = String
-- the compiler ---------- -- the compiler ----------
-------------------------- --------------------------
cf2gf :: String -> CF -> SourceGrammar cf2gf :: FilePath -> CF -> SourceGrammar
cf2gf name cf = mGrammar [ cf2gf fpath cf = mGrammar [
(aname, addFlag (modifyFlags (\fs -> fs{optStartCat = Just cat})) (aname, addFlag (modifyFlags (\fs -> fs{optStartCat = Just cat}))
(emptyModInfo{mtype = MTAbstract, jments = abs})), (emptyModInfo{mtype = MTAbstract, msrc=fpath, jments = abs})),
(cname, emptyModInfo{mtype = MTConcrete aname, jments = cnc}) (cname, emptyModInfo{mtype = MTConcrete aname, msrc=fpath, jments = cnc})
] ]
where where
name = justModuleName fpath
(abs,cnc,cat) = cf2grammar cf (abs,cnc,cat) = cf2grammar cf
aname = identS $ name ++ "Abs" aname = identS $ name ++ "Abs"
cname = identS name cname = identS name
@@ -99,7 +102,7 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where
cat = case rules of cat = case rules of
(L _ (_,(c,_))):_ -> c -- the value category of the first rule (L _ (_,(c,_))):_ -> c -- the value category of the first rule
_ -> error "empty CF" _ -> error "empty CF"
cats = [(cat, AbsCat (Just (L (0,0) []))) | cats = [(cat, AbsCat (Just (L NoLoc []))) |
cat <- nub (concat (map cf2cat rules))] ----notPredef cat cat <- nub (concat (map cf2cat rules))] ----notPredef cat
lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats] lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
(funs,lins) = unzip (map cf2rule rules) (funs,lins) = unzip (map cf2rule rules)

7
src/compiler/GF/Grammar/EBNF.hs
View File

@@ -24,13 +24,14 @@ import GF.Grammar.Grammar
import Data.Char import Data.Char
import Data.List import Data.List
import System.FilePath
-- AR 18/4/2000 - 31/3/2004 -- AR 18/4/2000 - 31/3/2004
getEBNF :: String -> String -> Err SourceGrammar getEBNF :: FilePath -> String -> Err SourceGrammar
getEBNF name = fmap (cf2gf name . ebnf2cf) . pEBNF getEBNF fpath = fmap (cf2gf fpath . ebnf2cf) . pEBNF
type EBNF = [ERule] type EBNF = [ERule]
type ERule = (ECat, ERHS) type ERule = (ECat, ERHS)
@@ -54,7 +55,7 @@ type CFJustRule = (CFCat, CFRHS)
ebnf2cf :: EBNF -> [CFRule] ebnf2cf :: EBNF -> [CFRule]
ebnf2cf ebnf = 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) mkCFF i (c, _) = ("Mk" ++ c ++ "_" ++ show i)
normEBNF :: EBNF -> [CFJustRule] normEBNF :: EBNF -> [CFJustRule]

14
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -20,7 +20,7 @@ module GF.Grammar.Grammar (SourceGrammar,
SourceModule, SourceModule,
mapSourceModule, mapSourceModule,
Info(..), Info(..),
L(..), unLoc, Location(..), L(..), unLoc,
Type, Type,
Cat, Cat,
Fun, 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 | AbsFun (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) (Maybe Bool) -- ^ (/ABS/) type, arrity and definition of a function
-- judgements in resource -- 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 | ResValue (L Type) -- ^ (/RES/) to mark parameter constructors for lookup
| ResOper (Maybe (L Type)) (Maybe (L Term)) -- ^ (/RES/) | ResOper (Maybe (L Type)) (Maybe (L Term)) -- ^ (/RES/)
@@ -94,8 +94,14 @@ data Info =
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical | AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
deriving Show deriving Show
data L a = L (Int,Int) a -- location information data Location
deriving (Eq,Show) = 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 instance Functor L where
fmap f (L loc x) = L loc (f x) fmap f (L loc x) = L loc (f x)

4
src/compiler/GF/Grammar/Lookup.hs
View File

@@ -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 -- 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 -- 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 = allOpers gr =
[((mo,op),typ,loc) | [((mo,op),typ,loc) |
(mo,minc) <- reachable, (mo,minc) <- reachable,
@@ -212,7 +212,7 @@ allOpers gr =
_ -> [] _ -> []
--- not for dependent types --- 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 allOpersTo gr ty = [op | op@(_,typ,_) <- allOpers gr, isProdTo ty typ] where
isProdTo t typ = eqProd typ t || case typ of isProdTo t typ = eqProd typ t || case typ of
Prod _ _ a b -> isProdTo t b Prod _ _ a b -> isProdTo t b

2
src/compiler/GF/Grammar/Macros.hs
View File

@@ -560,7 +560,7 @@ allDependencies ism b =
pts i = case i of pts i = case i of
ResOper pty pt -> [pty,pt] ResOper pty pt -> [pty,pt]
ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts] 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] CncCat pty _ _ -> [pty]
CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type)) CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type))
AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual

20
src/compiler/GF/Grammar/Parser.y
View File

@@ -5,7 +5,7 @@ module GF.Grammar.Parser
, pModDef , pModDef
, pModHeader , pModHeader
, pExp , pExp
, pTopDef , pTopDef
) where ) where
import GF.Infra.Ident import GF.Infra.Ident
@@ -118,14 +118,14 @@ ModDef
defs <- case buildAnyTree id jments of defs <- case buildAnyTree id jments of
Ok x -> return x Ok x -> return x
Bad msg -> fail msg 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 :: { SourceModule }
ModHeader ModHeader
: ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ; : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
(mtype,id) = $2 ; (mtype,id) = $2 ;
(extends,with,opens) = $4 } (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 :: { ModuleStatus }
ComplMod ComplMod
@@ -251,9 +251,9 @@ DataDef
ParamDef :: { [(Ident,Info)] } ParamDef :: { [(Ident,Info)] }
ParamDef ParamDef
: Ident '=' ListParConstr { ($1, ResParam (Just $3) Nothing) : : Posn Ident '=' ListParConstr Posn { ($2, ResParam (Just (mkL $1 $5 [param | L loc param <- $4])) Nothing) :
[(f, ResValue (L loc (mkProdSimple co (Cn $1)))) | L loc (f,co) <- $3] } [(f, ResValue (L loc (mkProdSimple co (Cn $2)))) | L loc (f,co) <- $4] }
| Ident { [($1, ResParam Nothing Nothing)] } | Posn Ident Posn { [($2, ResParam Nothing Nothing)] }
OperDef :: { [(Ident,Info)] } OperDef :: { [(Ident,Info)] }
OperDef OperDef
@@ -679,7 +679,7 @@ checkInfoType mt jment@(id,info) =
AbsFun pty _ pde _ -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde) AbsFun pty _ pde _ -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
CncCat pty pd ppn -> ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh ppn) CncCat pty pd ppn -> ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh ppn)
CncFun _ pd ppn -> ifConcrete mt (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) ResValue ty -> ifResource mt (locL ty)
ResOper pty pt -> ifOper mt pty pt ResOper pty pt -> ifOper mt pty pt
ResOverload _ xs -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs]) 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] locAll xs = [loc | L loc x <- xs]
locL (L loc x) = [loc] locL (L loc x) = [loc]
illegal ((s,e):_) = failLoc (Pn s 0) "illegal definition" illegal (Local s e:_) = failLoc (Pn s 0) "illegal definition"
illegal _ = return jment illegal _ = return jment
ifAbstract MTAbstract locs = return jment ifAbstract MTAbstract locs = return jment
ifAbstract _ locs = illegal locs ifAbstract _ locs = illegal locs
@@ -729,6 +729,6 @@ mkAlts cs = case cs of
_ -> fail "no strs from pattern" _ -> fail "no strs from pattern"
mkL :: Posn -> Posn -> x -> L x 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
} }

20
src/compiler/GF/Grammar/Printer.hs
View File

@@ -17,7 +17,7 @@ module GF.Grammar.Printer
, ppPatt , ppPatt
, ppValue , ppValue
, ppConstrs , ppConstrs
, ppPosition , ppLocation
, ppQIdent , ppQIdent
) where ) where
@@ -38,7 +38,7 @@ ppGrammar :: SourceGrammar -> Doc
ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr
ppModule :: TermPrintQual -> SourceModule -> Doc 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 hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr
where where
defs = Map.toList jments defs = Map.toList jments
@@ -97,8 +97,8 @@ ppJudgement q (id, AbsFun ptype _ pexp poper) =
ppJudgement q (id, ResParam pparams _) = ppJudgement q (id, ResParam pparams _) =
text "param" <+> ppIdent id <+> text "param" <+> ppIdent id <+>
(case pparams of (case pparams of
Just ps -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps)) Just (L _ ps) -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps))
_ -> empty) <+> semi _ -> empty) <+> semi
ppJudgement q (id, ResValue pvalue) = empty ppJudgement q (id, ResValue pvalue) = empty
ppJudgement q (id, ResOper ptype pexp) = ppJudgement q (id, ResOper ptype pexp) =
text "oper" <+> ppIdent id <+> 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 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 ppLocation :: FilePath -> Location -> Doc
ppPosition m (b,e) ppLocation fpath NoLoc = text fpath
| b == e = text "in" <+> ppIdent m <> text ".gf, line" <+> int b ppLocation fpath (External p l) = ppLocation p l
| otherwise = text "in" <+> ppIdent m <> text ".gf, lines" <+> int b <> text "-" <> int e 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))) commaPunct f ds = (hcat (punctuate comma (map f ds)))

16
src/compiler/GF/Infra/Modules.hs
View File

@@ -46,16 +46,11 @@ import GF.Data.Operations
import Data.List import Data.List
import qualified Data.Map as Map import qualified Data.Map as Map
import Text.PrettyPrint 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 -- 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), data MGrammar a = MGrammar { moduleMap :: Map.Map Ident (ModInfo a),
modules :: [(Ident,ModInfo a)] } modules :: [(Ident,ModInfo a)] }
deriving Show deriving Show
@@ -69,6 +64,7 @@ data ModInfo a = ModInfo {
mwith :: Maybe (Ident,MInclude,[(Ident,Ident)]), mwith :: Maybe (Ident,MInclude,[(Ident,Ident)]),
opens :: [OpenSpec], opens :: [OpenSpec],
mexdeps :: [Ident], mexdeps :: [Ident],
msrc :: FilePath,
jments :: Map.Map Ident a jments :: Map.Map Ident a
} }
deriving Show deriving Show
@@ -109,13 +105,13 @@ updateMGrammar (MGrammar omap os) (MGrammar nmap ns) =
nis = map fst ns nis = map fst ns
-} -}
updateModule :: ModInfo t -> Ident -> t -> ModInfo t 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 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 :: 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 :: Options -> ModInfo t -> ModInfo t
addFlag f mo = mo {flags = flags mo `addOptions` f} addFlag f mo = mo {flags = flags mo `addOptions` f}
@@ -227,7 +223,7 @@ emptyMGrammar :: MGrammar a
emptyMGrammar = mGrammar [] emptyMGrammar = mGrammar []
emptyModInfo :: ModInfo a 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 -- | we store the module type with the identifier

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

@@ -74,7 +74,7 @@ errors = fail . unlines
-- Types -- Types
data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeRun | ModeCompiler data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeRun | ModeCompiler
| ModeServer | ModeServer | ModeTags
deriving (Show,Eq,Ord) deriving (Show,Eq,Ord)
data Verbosity = Quiet | Normal | Verbose | Debug data Verbosity = Quiet | Normal | Verbose | Debug
@@ -299,6 +299,7 @@ optDescr =
Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).", 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 [] ["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 [] ["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 ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).",
Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.", Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .", Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .",

51
src/compiler/GFTags.hs Normal file
View File

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