msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests 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/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)))