GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-13 06:49:31 -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 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)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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 +
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]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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}