diff --git a/src-3.0/GF/Compile/CheckGrammar.hs b/src-3.0/GF/Compile/CheckGrammar.hs index 587c2bf18..fe4b7223c 100644 --- a/src-3.0/GF/Compile/CheckGrammar.hs +++ b/src-3.0/GF/Compile/CheckGrammar.hs @@ -69,24 +69,24 @@ checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod let js = jments mo checkRestrictedInheritance ms (name, mo) js' <- case mtype mo of - MTAbstract -> mapsCheckTree (checkAbsInfo gr name) js + MTAbstract -> mapsCheckTree (checkAbsInfo gr name mo) js - MTTransfer a b -> mapsCheckTree (checkAbsInfo gr name) js + MTTransfer a b -> mapsCheckTree (checkAbsInfo gr name mo) js - MTResource -> mapsCheckTree (checkResInfo gr name) js + MTResource -> mapsCheckTree (checkResInfo gr name mo) js MTConcrete a -> do checkErr $ topoSortOpers $ allOperDependencies name js ModMod abs <- checkErr $ lookupModule gr a js1 <- checkCompleteGrammar abs mo - mapsCheckTree (checkCncInfo gr name (a,abs)) js1 + mapsCheckTree (checkCncInfo gr name mo (a,abs)) js1 - MTInterface -> mapsCheckTree (checkResInfo gr name) js + MTInterface -> mapsCheckTree (checkResInfo gr name mo) js MTInstance a -> do ModMod abs <- checkErr $ lookupModule gr a -- checkCompleteInstance abs mo -- this is done in Rebuild - mapsCheckTree (checkResInfo gr name) js + mapsCheckTree (checkResInfo gr name mo) js return $ (name, ModMod (replaceJudgements mo js')) : ms @@ -126,8 +126,9 @@ justCheckLTerm src t = do ((t',_),_) <- checkStart (inferLType src t) return t' -checkAbsInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) -checkAbsInfo st m (c,info) = do +checkAbsInfo :: + SourceGrammar -> Ident -> Module Ident Info -> (Ident,Info) -> Check (Ident,Info) +checkAbsInfo st m mo (c,info) = do ---- checkReservedId c case info of AbsCat (Yes cont) _ -> mkCheck "category" $ @@ -147,12 +148,17 @@ checkAbsInfo st m (c,info) = do mkCheck cat ss = case ss of [] -> return (c,info) ["[]"] -> return (c,info) ---- - _ -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c + _ -> checkErr $ Bad (unlines ss ++++ "in" +++ cat +++ prt c +++ pos c) ---- temporary solution when tc of defs is incomplete mkCheckWarn cat ss = case ss of [] -> return (c,info) ["[]"] -> return (c,info) ---- - _ -> checkWarn (unlines ss ++++ "in" +++ cat +++ prt c) >> return (c,info) + _ -> do + checkWarn (unlines ss ++++ "in" +++ cat +++ prt c +++ pos c) + return (c,info) + + pos c = showPosition mo c + compAbsTyp g t = case t of Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g Let (x,(_,a)) b -> do @@ -205,8 +211,9 @@ checkCompleteGrammar abs cnc = do -- | General Principle: only Yes-values are checked. -- A May-value has always been checked in its origin module. -checkResInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) -checkResInfo gr mo (c,info) = do +checkResInfo :: + SourceGrammar -> Ident -> Module Ident Info -> (Ident,Info) -> Check (Ident,Info) +checkResInfo gr mo mm (c,info) = do checkReservedId c case info of ResOper pty pde -> chIn "operation" $ do @@ -243,8 +250,9 @@ checkResInfo gr mo (c,info) = do where infer = inferLType gr check = checkLType gr - chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") + chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ pos c +++ ":") comp = computeLType gr + pos c = showPosition mm c checkUniq xss = case xss of x:y:xs @@ -254,9 +262,10 @@ checkResInfo gr mo (c,info) = do _ -> return () -checkCncInfo :: SourceGrammar -> Ident -> (Ident,SourceAbs) -> +checkCncInfo :: SourceGrammar -> Ident -> Module Ident Info -> + (Ident,SourceAbs) -> (Ident,Info) -> Check (Ident,Info) -checkCncInfo gr m (a,abs) (c,info) = do +checkCncInfo gr m mo (a,abs) (c,info) = do checkReservedId c case info of @@ -281,14 +290,15 @@ checkCncInfo gr m (a,abs) (c,info) = do checkPrintname gr mpr return (c,CncCat (Yes typ') mdef' mpr) - _ -> checkResInfo gr m (c,info) + _ -> checkResInfo gr m mo (c,info) where env = gr infer = inferLType gr comp = computeLType gr check = checkLType gr - chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") + chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ pos c +++ ":") + pos c = showPosition mo c checkIfParType :: SourceGrammar -> Type -> Check () checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType typ) diff --git a/src-3.0/GF/Compile/Rebuild.hs b/src-3.0/GF/Compile/Rebuild.hs index 6dd6cf204..ec9076e1c 100644 --- a/src-3.0/GF/Compile/Rebuild.hs +++ b/src-3.0/GF/Compile/Rebuild.hs @@ -56,7 +56,10 @@ rebuildModule ms mo@(i,mi) = do m0s <- mapM (lookupModMod gr) j0s let notInM0 c _ = all (not . isInBinTree c . jments) m0s let js2 = filterBinTree notInM0 js' - return $ replaceJudgements m js2 + return $ (replaceJudgements m js2) + {positions = + buildTree (tree2list (positions m1) ++ + tree2list (positions m))} return $ ModMod m' _ -> return mi diff --git a/src-3.0/GF/Compile/Rename.hs b/src-3.0/GF/Compile/Rename.hs index 83bb97d50..28055b85e 100644 --- a/src-3.0/GF/Compile/Rename.hs +++ b/src-3.0/GF/Compile/Rename.hs @@ -58,7 +58,7 @@ renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod o ModMod mo -> do let js1 = jments mo status <- buildStatus (MGrammar ms) name mod - js2 <- mapsErrTree (renameInfo status) js1 + js2 <- mapsErrTree (renameInfo mo status) js1 let mod2 = ModMod $ mo {opens = map forceQualif (opens mo), jments = js2} return $ (name,mod2) : ms @@ -160,8 +160,9 @@ forceQualif o = case o of OSimple q i -> OQualif q i i OQualif q _ i -> OQualif q i i -renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info) -renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $ +renameInfo :: Module Ident Info -> Status -> (Ident,Info) -> Err (Ident,Info) +renameInfo mo status (i,info) = errIn + ("renaming definition of" +++ prt i +++ showPosition mo i) $ liftM ((,) i) $ case info of AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco) (renPerh (mapM rent) pfs) diff --git a/src-3.0/GF/Infra/Modules.hs b/src-3.0/GF/Infra/Modules.hs index 001818d46..797f729c8 100644 --- a/src-3.0/GF/Infra/Modules.hs +++ b/src-3.0/GF/Infra/Modules.hs @@ -34,6 +34,7 @@ module GF.Infra.Modules ( IdentM(..), typeOfModule, abstractOfConcrete, abstractModOfConcrete, lookupModule, lookupModuleType, lookupModMod, lookupInfo, + lookupPosition, showPosition, allModMod, isModAbs, isModRes, isModCnc, isModTrans, sameMType, isCompilableModule, isCompleteModule, allAbstracts, greatestAbstract, allResources, @@ -326,6 +327,16 @@ lookupModMod gr i = do lookupInfo :: (Show i, Ord i) => Module i a -> i -> Err a lookupInfo mo i = lookupTree show i (jments mo) +lookupPosition :: (Show i, Ord i) => Module i a -> i -> Err (String,(Int,Int)) +lookupPosition mo i = lookupTree show i (positions mo) + +showPosition :: (Show i, Ord i) => Module i a -> i -> String +showPosition mo i = case lookupPosition mo i of + Ok (f,(b,e)) | b == e -> "in" +++ f ++ ", line" +++ show b + Ok (f,(b,e)) -> "in" +++ f ++ ", lines" +++ show b ++ "-" ++ show e + _ -> "" + + allModMod :: (Show i,Eq i) => MGrammar i a -> [(i,Module i a)] allModMod gr = [(i,m) | (i, ModMod m) <- modules gr] diff --git a/src-3.0/GF/Source/SourceToGrammar.hs b/src-3.0/GF/Source/SourceToGrammar.hs index ca4f488ea..74b168b46 100644 --- a/src-3.0/GF/Source/SourceToGrammar.hs +++ b/src-3.0/GF/Source/SourceToGrammar.hs @@ -59,6 +59,11 @@ transName n = case n of IdentName i -> transIdent i ListName i -> liftM mkListId (transIdent i) +transNamePos :: Name -> Err (Ident,Int) +transNamePos n = case n of + IdentName i -> getIdentPos i + ListName i -> liftM (\ (c,p) -> (mkListId c,p)) (getIdentPos i) + transGrammar :: Grammar -> Err G.SourceGrammar transGrammar x = case x of Gr moddefs -> do @@ -108,9 +113,12 @@ transModDef x = case x of extends' <- transExtend extends opens' <- transOpens opens defs0 <- mapM trDef $ getTopDefs defs - defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] + poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds] + defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds] flags' <- return $ concatModuleOptions [o | Right o <- defs0] - return (id',GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs' poss)) + let poss1 = buildPosTree id' poss0 + return (id', + GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs' poss1)) MReuse _ -> do return (id', GM.ModMod (GM.Module mtyp' mstat' noModuleOptions [] [] emptyBinTree poss)) MUnion imps -> do @@ -127,10 +135,12 @@ transModDef x = case x of insts' <- mapM transOpen insts opens' <- transOpens opens defs0 <- mapM trDef $ getTopDefs defs - defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] + poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds] + defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds] flags' <- return $ concatModuleOptions [o | Right o <- defs0] + let poss1 = buildPosTree id' poss0 return (id', - GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs' poss) m' insts') + GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs' poss1) m' insts') mkModRes id mtyp body = do id' <- transIdent id @@ -217,31 +227,43 @@ transIncludedExt x = case x of ISome i ids -> liftM2 (,) (transIdent i) (liftM GM.MIOnly $ mapM transIdent ids) IMinus i ids -> liftM2 (,) (transIdent i) (liftM GM.MIExcept $ mapM transIdent ids) -transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] GO.ModuleOptions) +--- where no position is saved +nopos :: Int +nopos = -1 + +buildPosTree :: Ident -> [(Ident,Int)] -> BinTree Ident (String,(Int,Int)) +buildPosTree m = buildTree . mkPoss . filter ((>0) . snd) where + mkPoss cs = case cs of + (i,p):rest@((_,q):_) -> (i,(name,(p,max p (q-1)))) : mkPoss rest + (i,p):[] -> (i,(name,(p,p+100))) : [] --- don't know last line + _ -> [] + name = prIdent m ++ ".gf" ---- + +transAbsDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.ModuleOptions) transAbsDef x = case x of DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs DefFun fundefs -> do fundefs' <- mapM transFunDef fundefs - returnl [(fun, G.AbsFun (yes typ) nope) | (funs,typ) <- fundefs', fun <- funs] + returnl [(fun, nopos, G.AbsFun (yes typ) nope) | (funs,typ) <- fundefs', fun <- funs] DefFunData fundefs -> do fundefs' <- mapM transFunDef fundefs returnl $ - [(cat, G.AbsCat nope (yes [G.Cn fun])) | (funs,typ) <- fundefs', + [(cat, nopos, G.AbsCat nope (yes [G.Cn fun])) | (funs,typ) <- fundefs', fun <- funs, Ok (_,cat) <- [M.valCat typ] ] ++ - [(fun, G.AbsFun (yes typ) (yes G.EData)) | (funs,typ) <- fundefs', fun <- funs] + [(fun, nopos, G.AbsFun (yes typ) (yes G.EData)) | (funs,typ) <- fundefs', fun <- funs] DefDef defs -> do defs' <- liftM concat $ mapM getDefsGen defs - returnl [(c, G.AbsFun nope pe) | (c,(_,pe)) <- defs'] + returnl [(c, nopos, G.AbsFun nope pe) | ((c,p),(_,pe)) <- defs'] DefData ds -> do ds' <- mapM transDataDef ds returnl $ - [(c, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++ - [(f, G.AbsFun nope (yes G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf] + [(c, nopos, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++ + [(f, nopos, G.AbsFun nope (yes G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf] DefTrans defs -> do defs' <- liftM concat $ mapM getDefsGen defs - returnl [(c, G.AbsTrans f) | (c,(_,Yes f)) <- defs'] + returnl [(c, nopos, G.AbsTrans f) | ((c,p),(_,Yes f)) <- defs'] DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x where @@ -264,35 +286,35 @@ transFlagDef x = case x of -- | Cat definitions can also return some fun defs -- if it is a list category definition -transCatDef :: CatDef -> Err [(Ident, G.Info)] +transCatDef :: CatDef -> Err [(Ident, Int, G.Info)] transCatDef x = case x of SimpleCatDef id ddecls -> do - id' <- transIdent id - liftM (:[]) $ cat id' ddecls + (id',pos) <- getIdentPos id + liftM (:[]) $ cat id' pos ddecls ListCatDef id ddecls -> listCat id ddecls 0 ListSizeCatDef id ddecls size -> listCat id ddecls size where - cat i ddecls = do + cat i pos ddecls = do -- i <- transIdent id cont <- liftM concat $ mapM transDDecl ddecls - return (i, G.AbsCat (yes cont) nope) + return (i, pos, G.AbsCat (yes cont) nope) listCat id ddecls size = do - id' <- transIdent id + (id',pos) <- getIdentPos id let li = mkListId id' baseId = mkBaseId id' consId = mkConsId id' - catd0@(c,G.AbsCat (Yes cont0) _) <- cat li ddecls + catd0@(c,p,G.AbsCat (Yes cont0) _) <- cat li pos ddecls let - catd = (c,G.AbsCat (Yes cont0) (Yes [G.Cn baseId,G.Cn consId])) + catd = (c,pos,G.AbsCat (Yes cont0) (Yes [G.Cn baseId,G.Cn consId])) cont = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont0] xs = map (G.Vr . fst) cont cd = M.mkDecl (M.mkApp (G.Vr id') xs) lc = M.mkApp (G.Vr li) xs niltyp = M.mkProdSimple (cont ++ genericReplicate size cd) lc - nilfund = (baseId, G.AbsFun (yes niltyp) (yes G.EData)) + nilfund = (baseId, nopos, G.AbsFun (yes niltyp) (yes G.EData)) constyp = M.mkProdSimple (cont ++ [cd, M.mkDecl lc]) lc - consfund = (consId, G.AbsFun (yes constyp) (yes G.EData)) + consfund = (consId, nopos, G.AbsFun (yes constyp) (yes G.EData)) return [catd,nilfund,consfund] mkId x i = if isWildIdent x then (varX i) else x @@ -308,44 +330,38 @@ transDataDef x = case x of DataId id -> liftM G.Cn $ transIdent id DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id) -transResDef :: TopDef -> Err (Either [(Ident, G.Info)] GO.ModuleOptions) +transResDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.ModuleOptions) transResDef x = case x of DefPar pardefs -> do pardefs' <- mapM transParDef pardefs - returnl $ [(p, G.ResParam (if null pars + returnl $ [(p, nopos, G.ResParam (if null pars then nope -- abstract param type else (yes (pars,Nothing)))) | (p,pars) <- pardefs'] - ++ [(f, G.ResValue (yes (M.mkProdSimple co (G.Cn p),Nothing))) | + ++ [(f, nopos, G.ResValue (yes (M.mkProdSimple co (G.Cn p),Nothing))) | (p,pars) <- pardefs', (f,co) <- pars] -{- - ---- encoding of AnyInd without changing syntax. AR 20/9/2007 - DefOper [DDef [c] (EApp (EInt status) (EIdent mo))] -> do - c' <- transName c - mo' <- transIdent mo - return $ Left [(c',G.AnyInd (status==1) mo')] --} DefOper defs -> do defs' <- liftM concat $ mapM getDefs defs - returnl $ concatMap mkOverload [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs'] + returnl $ + concatMap mkOverload [(f, p, G.ResOper pt pe) | ((f,p),(pt,pe)) <- defs'] DefLintype defs -> do defs' <- liftM concat $ mapM getDefs defs - returnl [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs'] + returnl [(f, p, G.ResOper pt pe) | ((f,p),(pt,pe)) <- defs'] DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs _ -> Bad $ "illegal definition form in resource" +++ printTree x where - mkOverload (c,j) = case j of + mkOverload (c,p,j) = case j of G.ResOper _ (Yes (G.App keyw (G.R fs@(_:_:_)))) | isOverloading keyw c fs -> - [(c,G.ResOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])] + [(c,p,G.ResOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])] -- to enable separare type signature --- not type-checked G.ResOper (Yes (G.App keyw (G.RecType fs@(_:_:_)))) _ | isOverloading keyw c fs -> [] - _ -> [(c,j)] + _ -> [(c,p,j)] isOverloading keyw c fs = GP.prt keyw == "overload" && -- overload is a "soft keyword" all (== GP.prt c) (map (GP.prt . fst) fs) @@ -356,31 +372,31 @@ transParDef x = case x of ParDefAbs id -> liftM2 (,) (transIdent id) (return []) _ -> Bad $ "illegal definition in resource:" ++++ printTree x -transCncDef :: TopDef -> Err (Either [(Ident, G.Info)] GO.ModuleOptions) +transCncDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.ModuleOptions) transCncDef x = case x of DefLincat defs -> do defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, G.CncCat (yes t) nope nope) | (f,t) <- defs'] + returnl [(f, nopos, G.CncCat (yes t) nope nope) | (f,t) <- defs'] DefLindef defs -> do defs' <- liftM concat $ mapM getDefs defs - returnl [(f, G.CncCat pt pe nope) | (f,(pt,pe)) <- defs'] + returnl [(f, p, G.CncCat pt pe nope) | ((f,p),(pt,pe)) <- defs'] DefLin defs -> do defs' <- liftM concat $ mapM getDefs defs - returnl [(f, G.CncFun Nothing pe nope) | (f,(_,pe)) <- defs'] + returnl [(f, p, G.CncFun Nothing pe nope) | ((f,p),(_,pe)) <- defs'] DefPrintCat defs -> do defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, G.CncCat nope nope (yes e)) | (f,e) <- defs'] + returnl [(f, nopos, G.CncCat nope nope (yes e)) | (f,e) <- defs'] DefPrintFun defs -> do defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] + returnl [(f, nopos, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] DefPrintOld defs -> do --- a guess, for backward compatibility defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] + returnl [(f, nopos, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs DefPattern defs -> do defs' <- liftM concat $ mapM getDefs defs let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs'] - returnl [(f, G.CncFun Nothing (yes t) nope) | (f,t) <- defs2] + returnl [(f, p, G.CncFun Nothing (yes t) nope) | ((f,p),t) <- defs2] _ -> errIn ("illegal definition in concrete syntax:") $ transResDef x @@ -390,32 +406,32 @@ transPrintDef x = case x of (ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp) return $ [(i,e) | i <- ids] -getDefsGen :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))] +getDefsGen :: Def -> Err [((Ident, Int),(G.Perh G.Type, G.Perh G.Term))] getDefsGen d = case d of DDecl ids t -> do - ids' <- mapM transName ids + ids' <- mapM transNamePos ids t' <- transExp t return [(i,(yes t', nope)) | i <- ids'] DDef ids e -> do - ids' <- mapM transName ids + ids' <- mapM transNamePos ids e' <- transExp e return [(i,(nope, yes e')) | i <- ids'] DFull ids t e -> do - ids' <- mapM transName ids + ids' <- mapM transNamePos ids t' <- transExp t e' <- transExp e return [(i,(yes t', yes e')) | i <- ids'] DPatt id patts e -> do - id' <- transName id + id' <- transNamePos id ps' <- mapM transPatt patts e' <- transExp e return [(id',(nope, yes (G.Eqs [(ps',e')])))] -- | sometimes you need this special case, e.g. in linearization rules -getDefs :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))] +getDefs :: Def -> Err [((Ident,Int), (G.Perh G.Type, G.Perh G.Term))] getDefs d = case d of DPatt id patts e -> do - id' <- transName id + id' <- transNamePos id xs <- mapM tryMakeVar patts e' <- transExp e return [(id',(nope, yes (M.mkAbs xs e')))]