GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-06 09: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 5664c0699d
commit bc35626489
22 changed files with 232 additions and 129 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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