From d3a84f994b8738f8bbc50d1ea45d889ecf35528a Mon Sep 17 00:00:00 2001 From: krasimir Date: Mon, 22 Mar 2010 21:15:29 +0000 Subject: [PATCH] store and propagate the exact source location for all judgements in the grammar. It may not be used accurately in the error messages yet --- lib/src/abstract/Lexicon.gf | 4 - lib/src/bulgarian/MorphoFunsBul.gf | 7 - lib/src/catalan/IrregCatAbs.gf | 2 - lib/src/prelude/Formal.gf | 1 - src/compiler/GF/Compile.hs | 3 +- src/compiler/GF/Compile/Abstract/TypeCheck.hs | 4 +- src/compiler/GF/Compile/CheckGrammar.hs | 74 ++++----- src/compiler/GF/Compile/Coding.hs | 14 +- src/compiler/GF/Compile/GrammarToPGF.hs | 37 +++-- src/compiler/GF/Compile/Optimize.hs | 27 ++-- src/compiler/GF/Compile/Refresh.hs | 14 +- src/compiler/GF/Compile/Rename.hs | 78 ++++----- src/compiler/GF/Compile/SubExOpt.hs | 20 +-- src/compiler/GF/Compile/Update.hs | 37 ++--- src/compiler/GF/Grammar/Binary.hs | 12 +- src/compiler/GF/Grammar/CF.hs | 22 +-- src/compiler/GF/Grammar/Grammar.hs | 26 ++- src/compiler/GF/Grammar/Lookup.hs | 34 ++-- src/compiler/GF/Grammar/Macros.hs | 6 +- src/compiler/GF/Grammar/Parser.y | 150 +++++++++--------- src/compiler/GF/Grammar/Printer.hs | 48 +++--- src/compiler/GF/Infra/Modules.hs | 21 +-- src/compiler/GFI.hs | 4 +- 23 files changed, 322 insertions(+), 323 deletions(-) diff --git a/lib/src/abstract/Lexicon.gf b/lib/src/abstract/Lexicon.gf index 2c2a97c0f..37c0cfe8b 100644 --- a/lib/src/abstract/Lexicon.gf +++ b/lib/src/abstract/Lexicon.gf @@ -79,7 +79,6 @@ fun door_N : N ; do_V2 : V2 ; drink_V2 : V2 ; - drink_V2 : V2 ; dry_A : A ; dull_A : A ; dust_N : N ; @@ -87,7 +86,6 @@ fun earth_N : N ; easy_A2V : A2 ; eat_V2 : V2 ; - eat_V2 : V2 ; egg_N : N ; empty_A : A ; enemy_N : N ; @@ -140,7 +138,6 @@ fun head_N : N ; heart_N : N ; hear_V2 : V2 ; - hear_V2 : V2 ; heavy_A : A ; hill_N : N ; hit_V2 : V2 ; @@ -255,7 +252,6 @@ fun seed_N : N ; seek_V2 : V2 ; see_V2 : V2 ; - see_V2 : V2 ; sell_V3 : V3 ; send_V3 : V3 ; sew_V : V ; diff --git a/lib/src/bulgarian/MorphoFunsBul.gf b/lib/src/bulgarian/MorphoFunsBul.gf index a553e932a..fa7204003 100644 --- a/lib/src/bulgarian/MorphoFunsBul.gf +++ b/lib/src/bulgarian/MorphoFunsBul.gf @@ -125,16 +125,9 @@ oper mkVA : V -> VA ; mkVA v = v ** {lock_VA = <>} ; - - mkV2A : V -> Prep -> V2A ; - mkV2A v p = prepV2 v p ** {lock_V2A = <>} ; mkVQ : V -> VQ ; mkVQ v = v ** {lock_VQ = <>} ; - - mkV2Q : V -> Prep -> V2Q ; - mkV2Q v p = prepV2 v p ** {lock_V2Q = <>} ; - --2 Nouns diff --git a/lib/src/catalan/IrregCatAbs.gf b/lib/src/catalan/IrregCatAbs.gf index d5aa65fc6..a85f1c653 100644 --- a/lib/src/catalan/IrregCatAbs.gf +++ b/lib/src/catalan/IrregCatAbs.gf @@ -1087,8 +1087,6 @@ abstract IrregCatAbs = Cat ** { -- fun zaherir_V : V ; -- fun zambullir_V : V ; -- fun zurcir_V : V ; -fun haver_V : V ; -fun estar_V : V ; fun callar_V : V ; fun caure_V : V ; fun cloure_V : V ; diff --git a/lib/src/prelude/Formal.gf b/lib/src/prelude/Formal.gf index 2aa33d9ef..c53c63b7f 100644 --- a/lib/src/prelude/Formal.gf +++ b/lib/src/prelude/Formal.gf @@ -3,7 +3,6 @@ resource Formal = open Prelude in { -- to replace the old library Precedence oper - Prec : PType ; TermPrec : Type = {s : Str ; p : Prec} ; mkPrec : Prec -> Str -> TermPrec = \p,s -> diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index f6d346320..a862f85e2 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -210,8 +210,7 @@ generateModuleCode :: Options -> FilePath -> SourceModule -> IOE SourceModule generateModuleCode opts file minfo = do let minfo1 = subexpModule minfo minfo2 = case minfo1 of - (m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi) - , positions=Map.empty}) + (m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)}) putPointE Normal opts (" wrote file" +++ file) $ ioeIO $ encodeFile file minfo2 return minfo1 diff --git a/src/compiler/GF/Compile/Abstract/TypeCheck.hs b/src/compiler/GF/Compile/Abstract/TypeCheck.hs index 2632c54dd..bddc6f0c0 100644 --- a/src/compiler/GF/Compile/Abstract/TypeCheck.hs +++ b/src/compiler/GF/Compile/Abstract/TypeCheck.hs @@ -72,9 +72,9 @@ checkContext st = checkTyp st . cont2exp checkTyp :: SourceGrammar -> Type -> [Message] checkTyp gr typ = err (\x -> [text x]) ppConstrs $ justTypeCheck gr typ vType -checkDef :: SourceGrammar -> Fun -> Type -> [Equation] -> [Message] +checkDef :: SourceGrammar -> Fun -> Type -> [L Equation] -> [Message] checkDef gr (m,fun) typ eqs = err (\x -> [text x]) ppConstrs $ do - bcs <- mapM (\b -> checkBranch (grammar2theory gr) (initTCEnv []) b (type2val typ)) eqs + bcs <- mapM (\(L _ b) -> checkBranch (grammar2theory gr) (initTCEnv []) b (type2val typ)) eqs let (bs,css) = unzip bcs (constrs,_) <- unifyVal (concat css) return $ filter notJustMeta constrs diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 84ecdde0a..a61192500 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -94,7 +94,8 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do where checkAbs js i@(c,info) = case info of - AbsFun (Just ty) _ _ -> do let mb_def = do + AbsFun (Just (L loc ty)) _ _ + -> do let mb_def = do let (cxt,(_,i),_) = typeForm ty info <- lookupIdent i js info <- case info of @@ -102,8 +103,8 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do return info _ -> return info case info of - CncCat (Just (RecType [])) _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt) - _ -> Bad "no def lin" + CncCat (Just (L loc (RecType []))) _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt) + _ -> Bad "no def lin" case lookupIdent c js of Ok (AnyInd _ _) -> return js @@ -111,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 def) pn) js + Ok def -> return $ updateTree (c,CncFun ty (Just (L (0,0) 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 def) Nothing) js + return $ updateTree (c,CncFun (Just linty) (Just (L (0,0) def)) Nothing) js Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c return js AbsCat (Just _) -> case lookupIdent c js of @@ -127,17 +128,17 @@ 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 defLinType) mt mp) js + return $ updateTree (c,CncCat (Just (L (0,0) defLinType)) mt mp) js _ -> do checkWarn $ text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}" - return $ updateTree (c,CncCat (Just defLinType) Nothing Nothing) js + return $ updateTree (c,CncCat (Just (L (0,0) defLinType)) Nothing Nothing) js _ -> return js checkCnc js i@(c,info) = case info of CncFun _ d pn -> case lookupOrigInfo gr am c of - Ok (_,AbsFun (Just ty) _ _) -> + Ok (_,AbsFun (Just (L _ ty)) _ _) -> do (cont,val) <- linTypeOfType gr cm ty let linty = (snd (valCat ty),cont,val) return $ updateTree (c,CncFun (Just linty) d pn) js @@ -156,50 +157,51 @@ checkInfo :: [SourceModule] -> SourceModule -> Ident -> Info -> Check Info checkInfo ms (m,mo) c info = do checkReservedId c case info of - AbsCat (Just cont) -> mkCheck "category" $ - checkContext gr cont + AbsCat (Just (L loc cont)) -> + mkCheck loc "category" $ + checkContext gr cont - AbsFun (Just typ0) ma md -> do + AbsFun (Just (L loc typ0)) ma md -> do typ <- compAbsTyp [] typ0 -- to calculate let definitions - mkCheck "type of function" $ + mkCheck loc "type of function" $ checkTyp gr typ case md of - Just eqs -> mkCheck "definition of function" $ + Just eqs -> mkCheck loc "definition of function" $ checkDef gr (m,c) typ eqs Nothing -> return info - return (AbsFun (Just typ) ma md) + return (AbsFun (Just (L loc typ)) ma md) - CncFun linty@(Just (cat,cont,val)) (Just trm) mpr -> chIn "linearization of" $ do + CncFun linty@(Just (cat,cont,val)) (Just (L loc trm)) mpr -> chIn loc "linearization of" $ do (trm',_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars mpr <- checkPrintname gr mpr - return (CncFun linty (Just trm') mpr) + return (CncFun linty (Just (L loc trm')) mpr) - CncCat (Just typ) mdef mpr -> chIn "linearization type of" $ do + CncCat (Just (L loc typ)) mdef mpr -> chIn loc "linearization type of" $ do (typ,_) <- checkLType gr [] typ typeType typ <- computeLType gr [] typ mdef <- case mdef of - Just def -> do + Just (L loc def) -> do (def,_) <- checkLType gr [] def (mkFunType [typeStr] typ) - return $ Just def + return $ Just (L loc def) _ -> return mdef mpr <- checkPrintname gr mpr - return (CncCat (Just typ) mdef mpr) + return (CncCat (Just (L loc typ)) mdef mpr) - ResOper pty pde -> chIn "operation" $ do + ResOper pty pde -> chIn (0,0) "operation" $ do (pty', pde') <- case (pty,pde) of - (Just ty, Just de) -> do + (Just (L loc1 ty), Just (L loc2 de)) -> do ty' <- checkLType gr [] ty typeType >>= computeLType gr [] . fst (de',_) <- checkLType gr [] de ty' - return (Just ty', Just de') - (_ , Just de) -> do + return (Just (L loc1 ty'), Just (L loc2 de')) + (_ , Just (L loc de)) -> do (de',ty') <- inferLType gr [] de - return (Just ty', Just de') + return (Just (L loc ty'), Just (L loc de')) (_ , Nothing) -> do checkError (text "No definition given to the operation") return (ResOper pty' pde') - ResOverload os tysts -> chIn "overloading" $ do - tysts' <- mapM (uncurry $ flip (checkLType gr [])) tysts -- return explicit ones + ResOverload os tysts -> chIn (0,0) "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 [])) [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0] @@ -209,16 +211,16 @@ 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) _ -> chIn "parameter type" $ do + ResParam (Just pcs) _ -> chIn (0,0) "parameter type" $ do ts <- checkErr $ liftM concat $ mapM mkPar pcs return (ResParam (Just pcs) (Just ts)) _ -> return info where gr = MGrammar ((m,mo) : ms) - chIn cat = checkIn (text "Happened in" <+> text cat <+> ppIdent c <+> ppPosition mo c <> colon) + chIn loc cat = checkIn (text "Happened in" <+> text cat <+> ppIdent c <+> ppPosition m loc <> colon) - mkPar (f,co) = do + mkPar (L _ (f,co)) = do vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co return $ map (mkApp (QC m f)) vs @@ -229,9 +231,9 @@ checkInfo ms (m,mo) c info = do | otherwise -> checkUniq $ y:xs _ -> return () - mkCheck cat ss = case ss of + mkCheck loc cat ss = case ss of [] -> return info - _ -> checkError (vcat ss $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition mo c) + _ -> checkError (vcat ss $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition m loc) compAbsTyp g t = case t of Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g @@ -246,10 +248,10 @@ checkInfo ms (m,mo) c info = do _ -> composOp (compAbsTyp g) t -checkPrintname :: SourceGrammar -> Maybe Term -> Check (Maybe Term) -checkPrintname gr (Just t) = do (t,_) <- checkLType gr [] t typeStr - return (Just t) -checkPrintname gr Nothing = return Nothing +checkPrintname :: SourceGrammar -> Maybe (L Term) -> Check (Maybe (L Term)) +checkPrintname gr (Just (L loc t)) = do (t,_) <- checkLType gr [] t typeStr + return (Just (L loc t)) +checkPrintname gr Nothing = return Nothing -- | for grammars obtained otherwise than by parsing ---- update!! checkReservedId :: Ident -> Check () diff --git a/src/compiler/GF/Compile/Coding.hs b/src/compiler/GF/Compile/Coding.hs index 49538bd35..b909aac7d 100644 --- a/src/compiler/GF/Compile/Coding.hs +++ b/src/compiler/GF/Compile/Coding.hs @@ -25,13 +25,15 @@ codeSourceModule co (id,mo) = (id,replaceJudgements mo (mapTree codj (jments mo) CncFun mty pt mpr -> CncFun mty (fmap (codeTerm co) pt) (fmap (codeTerm co) mpr) _ -> info -codeTerm :: (String -> String) -> Term -> Term -codeTerm co t = case t of - K s -> K (co s) - T ty cs -> T ty [(codp p,codeTerm co v) | (p,v) <- cs] - EPatt p -> EPatt (codp p) - _ -> composSafeOp (codeTerm co) t +codeTerm :: (String -> String) -> L Term -> L Term +codeTerm co (L loc t) = L loc (codt t) where + codt t = case t of + K s -> K (co s) + T ty cs -> T ty [(codp p,codt v) | (p,v) <- cs] + EPatt p -> EPatt (codp p) + _ -> composSafeOp codt t + codp p = case p of --- really: composOpPatt PR rs -> PR [(l,codp p) | (l,p) <- rs] PString s -> PString (co s) diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index 3db308f68..cb447f536 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -60,7 +60,7 @@ canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do gflags = Map.empty aflags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags abm)] - mkDef (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] + mkDef (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] mkDef Nothing = Nothing mkArrity (Just a) = a @@ -68,10 +68,10 @@ canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do -- concretes lfuns = [(f', (mkType [] ty, mkArrity ma, mkDef pty)) | - (f,AbsFun (Just ty) ma pty) <- tree2list (M.jments abm), let f' = i2i f] + (f,AbsFun (Just (L _ ty)) ma pty) <- tree2list (M.jments abm), let f' = i2i f] funs = Map.fromAscList lfuns lcats = [(i2i c, snd (mkContext [] cont)) | - (c,AbsCat (Just cont)) <- tree2list (M.jments abm)] + (c,AbsCat (Just (L _ cont))) <- tree2list (M.jments abm)] cats = Map.fromAscList lcats catfuns = Map.fromList [(cat,[f | (f, (C.DTyp _ c _,_,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] @@ -91,16 +91,16 @@ canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do ---- then (trace "decode" D.convertStringsInTerm decodeUTF8) else id umkTerm = utf . mkTerm lins = Map.fromAscList - [(f', umkTerm tr) | (f,CncFun _ (Just tr) _) <- js, + [(f', umkTerm tr) | (f,CncFun _ (Just (L _ tr)) _) <- js, let f' = i2i f, exists f'] -- eliminating lins without fun -- needed even here because of restricted inheritance lincats = Map.fromAscList - [(i2i c, mkCType ty) | (c,CncCat (Just ty) _ _) <- js] + [(i2i c, mkCType ty) | (c,CncCat (Just (L _ ty)) _ _) <- js] lindefs = Map.fromAscList - [(i2i c, umkTerm tr) | (c,CncCat _ (Just tr) _) <- js] + [(i2i c, umkTerm tr) | (c,CncCat _ (Just (L _ tr)) _) <- js] printnames = Map.union - (Map.fromAscList [(i2i f, realize (umkTerm tr)) | (f,CncFun _ _ (Just tr)) <- js]) - (Map.fromAscList [(i2i f, realize (umkTerm tr)) | (f,CncCat _ _ (Just tr)) <- js]) + (Map.fromAscList [(i2i f, realize (umkTerm tr)) | (f,CncFun _ _ (Just (L _ tr))) <- js]) + (Map.fromAscList [(i2i f, realize (umkTerm tr)) | (f,CncCat _ _ (Just (L _ tr))) <- js]) params = Map.fromAscList [(i2i c, pars lang0 c) | (c,CncCat (Just ty) _ _) <- js] fcfg = Nothing @@ -236,16 +236,15 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do reorder :: Ident -> SourceGrammar -> SourceGrammar reorder abs cg = M.MGrammar $ - (abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs poss): - [(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js) poss) + (abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs): + [(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js)) | (c,(fs,js)) <- cncs] where - poss = emptyBinTree -- positions no longer needed mos = M.modules cg adefs = sorted2tree $ sortIds $ predefADefs ++ Look.allOrigInfos cg abs predefADefs = - [(c, AbsCat (Just [])) | c <- [cFloat,cInt,cString]] + [(c, AbsCat (Just (L (0,0) []))) | c <- [cFloat,cInt,cString]] aflags = concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo] @@ -259,7 +258,7 @@ reorder abs cg = M.MGrammar $ Just r <- [lookup i (M.allExtendSpecs cg la)]] predefCDefs = - [(c, CncCat (Just GM.defLinType) Nothing Nothing) | c <- [cInt,cFloat,cString]] + [(c, CncCat (Just (L (0,0) GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]] sortIds = sortBy (\ (f,_) (g,_) -> compare f g) @@ -292,8 +291,8 @@ canon2canon opts abs cg0 = j2j cg (f,j) = let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in case j of - CncFun x (Just tr) z -> CncFun x (Just (debug (t2t (unfactor cg0 tr)))) z - CncCat (Just ty) (Just x) y -> CncCat (Just (ty2ty ty)) (Just (t2t (unfactor cg0 x))) y + CncFun x (Just (L loc tr)) z -> CncFun x (Just (L loc (debug (t2t (unfactor cg0 tr))))) z + CncCat (Just (L locty ty)) (Just (L locx x)) y -> CncCat (Just (L locty (ty2ty ty))) (Just (L locx (t2t (unfactor cg0 x)))) y _ -> j where cg1 = cg @@ -315,7 +314,7 @@ canon2canon opts abs cg0 = -- flatten record arguments of param constructors p2p (f,j) = case j of ResParam (Just ps) (Just vs) -> - ResParam (Just [(c,concatMap unRec cont) | (c,cont) <- ps]) (Just (map unrec vs)) + ResParam (Just [L loc (c,concatMap unRec cont) | L loc (c,cont) <- ps]) (Just (map unrec vs)) _ -> j unRec (bt,x,ty) = case ty of RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (Explicit,identW,typ)] @@ -359,13 +358,13 @@ paramValues cgr = (labels,untyps,typs) where partyps = nub $ --- [App (Q (IC "Predef") (IC "Ints")) (EInt i) | i <- [1,9]] ---linTypeInt [ty | - (_,(_,CncCat (Just ty0) _ _)) <- jments, + (_,(_,CncCat (Just (L _ ty0)) _ _)) <- jments, ty <- typsFrom ty0 ] ++ [ Q m ty | (m,(ty,ResParam _ _)) <- jments ] ++ [ty | - (_,(_,CncFun _ (Just tr) _)) <- jments, + (_,(_,CncFun _ (Just (L _ tr)) _)) <- jments, ty <- err (const []) snd $ appSTM (typsFromTrm tr) [] ] params = [(ty, errVal (traceD ("UNKNOWN PARAM TYPE" +++ show ty) []) $ @@ -407,7 +406,7 @@ paramValues cgr = (labels,untyps,typs) where [(cat,[f | let RecType fs = GM.defLinType, f <- fs]) | cat <- [cInt,cFloat, cString]] ++ reverse ---- TODO: really those lincats that are reached ---- reverse is enough to expel overshadowed ones... - [(cat,ls) | (_,(cat,CncCat (Just ty) _ _)) <- jments, + [(cat,ls) | (_,(cat,CncCat (Just (L _ ty)) _ _)) <- jments, RecType ls <- [unlockTy ty]] labels = Map.fromList $ concat [((cat,[lab]),(typ,i)): diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs index 2c556b36f..a9e182f7f 100644 --- a/src/compiler/GF/Compile/Optimize.hs +++ b/src/compiler/GF/Compile/Optimize.hs @@ -64,24 +64,24 @@ evalInfo opts ms m c info = do CncCat ptyp pde ppr -> do pde' <- case (ptyp,pde) of - (Just typ, Just de) -> do + (Just (L _ typ), Just (L loc de)) -> do de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de - return (Just (factor param c 0 de)) - (Just typ, Nothing) -> do + return (Just (L loc (factor param c 0 de))) + (Just (L loc typ), Nothing) -> do de <- mkLinDefault gr typ de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de - return (Just (factor param c 0 de)) + return (Just (L loc (factor param c 0 de))) _ -> return pde -- indirection - ppr' <- liftM Just $ evalPrintname gr c ppr (Just $ K $ showIdent c) + ppr' <- liftM Just $ evalPrintname gr c ppr (Just (L (0,0) (K $ showIdent c))) return (CncCat ptyp pde' ppr') CncFun (mt@(Just (_,cont,val))) pde ppr -> --trace (prt c) $ eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do pde' <- case pde of - Just de -> do de <- partEval opts gr (cont,val) de - return (Just (factor param c 0 de)) + Just (L loc de) -> do de <- partEval opts gr (cont,val) de + return (Just (L loc (factor param c 0 de))) Nothing -> return pde ppr' <- liftM Just $ evalPrintname gr c ppr pde' return $ CncFun mt pde' ppr' -- only cat in type actually needed @@ -89,8 +89,8 @@ evalInfo opts ms m c info = do ResOper pty pde | OptExpand `Set.member` optim -> do pde' <- case pde of - Just de -> do de <- computeConcrete gr de - return (Just (factor param c 0 de)) + Just (L loc de) -> do de <- computeConcrete gr de + return (Just (L loc (factor param c 0 de))) Nothing -> return Nothing return $ ResOper pty pde' @@ -161,13 +161,14 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ -- lin for functions, cat name for cats (dispatch made in evalCncDef above). --- We cannot use linearization at this stage, since we do not know the --- defaults we would need for question marks - and we're not yet in canon. -evalPrintname :: SourceGrammar -> Ident -> Maybe Term -> Maybe Term -> Err Term +evalPrintname :: SourceGrammar -> Ident -> Maybe (L Term) -> Maybe (L Term) -> Err (L Term) evalPrintname gr c ppr lin = case ppr of - Just pr -> comp pr + Just (L loc pr) -> do pr <- comp pr + return (L loc pr) Nothing -> case lin of - Just t -> return $ K $ clean $ render (ppTerm Unqualified 0 (oneBranch t)) - Nothing -> return $ K $ showIdent c ---- + Just (L loc t) -> return $ L loc (K $ clean $ render (ppTerm Unqualified 0 (oneBranch t))) + Nothing -> return $ L (0,0) (K $ showIdent c) ---- where comp = computeConcrete gr diff --git a/src/compiler/GF/Compile/Refresh.hs b/src/compiler/GF/Compile/Refresh.hs index 04800fcce..1ecc99788 100644 --- a/src/compiler/GF/Compile/Refresh.hs +++ b/src/compiler/GF/Compile/Refresh.hs @@ -116,18 +116,18 @@ refreshModule (k,ms) mi@(i,mo) | otherwise = return (k, mi:ms) where refreshRes (k,cs) ci@(c,info) = case info of - ResOper ptyp (Just trm) -> do ---- refresh ptyp + ResOper ptyp (Just (L loc trm)) -> do ---- refresh ptyp (k',trm') <- refreshTermKN k trm - return $ (k', (c, ResOper ptyp (Just trm')):cs) + return $ (k', (c, ResOper ptyp (Just (L loc trm'))):cs) ResOverload os tyts -> do (k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $ - appSTM (mapPairsM refresh tyts) (initIdStateN k) + appSTM (mapPairsM (\(L loc t) -> liftM (L loc) (refresh t)) tyts) (initIdStateN k) return $ (k', (c, ResOverload os tyts'):cs) - CncCat mt (Just trm) pn -> do ---- refresh mt, pn + CncCat mt (Just (L loc trm)) pn -> do ---- refresh mt, pn (k',trm') <- refreshTermKN k trm - return $ (k', (c, CncCat mt (Just trm') pn):cs) - CncFun mt (Just trm) pn -> do ---- refresh pn + return $ (k', (c, CncCat mt (Just (L loc trm')) pn):cs) + CncFun mt (Just (L loc trm)) pn -> do ---- refresh pn (k',trm') <- refreshTermKN k trm - return $ (k', (c, CncFun mt (Just trm') pn):cs) + return $ (k', (c, CncFun mt (Just (L loc trm')) pn):cs) _ -> return (k, ci:cs) diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index 59a8c6a3d..f7ca8fb28 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -54,7 +54,7 @@ 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 mo status) js1 + js2 <- checkMap (renameInfo status name) js1 return (name, mo {opens = map forceQualif (opens mo), jments = js2}) type Status = (StatusTree, [(OpenSpec, StatusTree)]) @@ -137,31 +137,49 @@ forceQualif o = case o of OSimple i -> OQualif i i OQualif _ i -> OQualif i i -renameInfo :: SourceModInfo -> Status -> Ident -> Info -> Check Info -renameInfo mo status i info = checkIn - (text "renaming definition of" <+> ppIdent i <+> ppPosition mo i) $ - case info of - AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco) - AbsFun pty pa ptr -> liftM3 AbsFun (ren pty) (return pa) (renPerh (mapM (renameEquation status [])) ptr) - ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr) - ResOverload os tysts -> - liftM (ResOverload os) (mapM (pairM rent) tysts) +renameInfo :: Status -> Ident -> Ident -> Info -> Check Info +renameInfo status m i info = + case info of + AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco) + AbsFun pty pa ptr -> liftM3 AbsFun (renTerm pty) (return pa) (renMaybe (mapM (renLoc (renEquation status))) ptr) + 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 + return (ResParam (Just pp') m) + ResValue t -> do + t <- renLoc (renameTerm status []) t + return (ResValue t) + CncCat pty ptr ppr -> liftM3 CncCat (renTerm pty) (renTerm ptr) (renTerm ppr) + CncFun mt ptr ppr -> liftM2 (CncFun mt) (renTerm ptr) (renTerm ppr) + _ -> return info + where + renTerm = renPerh (renameTerm status []) - ResParam (Just pp) m -> do - pp' <- mapM (renameParam status) pp - return (ResParam (Just pp') m) - ResValue t -> do - t <- rent t - return (ResValue t) - CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr) - CncFun mt ptr ppr -> liftM2 (CncFun mt) (ren ptr) (ren ppr) - _ -> return info - where - ren = renPerh rent - rent = renameTerm status [] + renPerh ren = renMaybe (renLoc ren) -renPerh ren (Just t) = liftM Just $ ren t -renPerh ren Nothing = return Nothing + renMaybe ren (Just x) = ren x >>= return . Just + renMaybe ren Nothing = return Nothing + + renLoc ren (L loc x) = + checkIn (text "renaming of" <+> ppIdent i <+> ppPosition m loc) $ do + x <- ren x + return (L loc x) + + renPair ren (L locx x, L locy y) = do x <- ren x + y <- ren y + return (L locx x, L locy y) + + renEquation :: Status -> Equation -> Check Equation + renEquation b (ps,t) = do + (ps',vs) <- liftM unzip $ mapM (renamePattern b) ps + t' <- renameTerm b (concat vs) t + return (ps',t') + + renParam :: Status -> Param -> Check Param + renParam env (c,co) = do + co' <- renameContext env co + return (c,co') renameTerm :: Status -> [Ident] -> Term -> Check Term renameTerm env vars = ren vars where @@ -283,11 +301,6 @@ renamePattern env patt = case patt of renp = renamePattern env renid = renameIdentTerm env -renameParam :: Status -> (Ident, Context) -> Check (Ident, Context) -renameParam env (c,co) = do - co' <- renameContext env co - return (c,co') - renameContext :: Status -> Context -> Check Context renameContext b = renc [] where renc vs cont = case cont of @@ -303,10 +316,3 @@ renameContext b = renc [] where return $ (bt,x,t') : xts' _ -> return cont ren = renameTerm b - --- | vars not needed in env, since patterns always overshadow old vars -renameEquation :: Status -> [Ident] -> Equation -> Check Equation -renameEquation b vs (ps,t) = do - (ps',vs') <- liftM unzip $ mapM (renamePattern b) ps - t' <- renameTerm b (concat vs' ++ vs) t - return (ps',t') diff --git a/src/compiler/GF/Compile/SubExOpt.hs b/src/compiler/GF/Compile/SubExOpt.hs index c7dbb5d3d..73c349881 100644 --- a/src/compiler/GF/Compile/SubExOpt.hs +++ b/src/compiler/GF/Compile/SubExOpt.hs @@ -53,9 +53,9 @@ unsubexpModule sm@(i,mo) -- perform this iff the module has opers hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs] unparInfo (c,info) = case info of - CncFun xs (Just t) m -> [(c, CncFun xs (Just (unparTerm t)) m)] - ResOper (Just (EInt 8)) _ -> [] -- subexp-generated opers - ResOper pty (Just t) -> [(c, ResOper pty (Just (unparTerm t)))] + CncFun xs (Just (L loc t)) m -> [(c, CncFun xs (Just (L loc (unparTerm t))) m)] + ResOper (Just (L loc (EInt 8))) _ -> [] -- subexp-generated opers + ResOper pty (Just (L loc t)) -> [(c, ResOper pty (Just (L loc (unparTerm t))))] _ -> [(c,info)] unparTerm t = case t of Q m c | isOperIdent c -> --- name convention of subexp opers @@ -76,12 +76,12 @@ addSubexpConsts mo tree lins = do mapM mkOne $ opers ++ lins where mkOne (f,def) = case def of - CncFun xs (Just trm) pn -> do + CncFun xs (Just (L loc trm)) pn -> do trm' <- recomp f trm - return (f,CncFun xs (Just trm') pn) - ResOper ty (Just trm) -> do + return (f,CncFun xs (Just (L loc trm')) pn) + ResOper ty (Just (L loc trm)) -> do trm' <- recomp f trm - return (f,ResOper ty (Just trm')) + return (f,ResOper ty (Just (L loc trm'))) _ -> return (f,def) recomp f t = case Map.lookup t tree of Just (_,id) | operIdent id /= f -> return $ Q mo (operIdent id) @@ -89,7 +89,7 @@ addSubexpConsts mo tree lins = do list = Map.toList tree - oper id trm = (operIdent id, ResOper (Just (EInt 8)) (Just trm)) + oper id trm = (operIdent id, ResOper (Just (L (0,0) (EInt 8))) (Just (L (0,0) trm))) --- impossible type encoding generated opers getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int)) @@ -99,10 +99,10 @@ getSubtermsMod mo js = do return $ Map.filter (\ (nu,_) -> nu > 1) tree0 where getInfo get fi@(f,i) = case i of - CncFun xs (Just trm) pn -> do + CncFun xs (Just (L _ trm)) pn -> do get trm return $ fi - ResOper ty (Just trm) -> do + ResOper ty (Just (L _ trm)) -> do get trm return $ fi _ -> return fi diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 6ee0dc65b..1da650340 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -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_ ps_)) = do +rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ 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 @@ -100,8 +100,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do m0s <- mapM (lookupModule gr) j0s let notInM0 c _ = all (not . isInBinTree c . jments) m0s let js2 = filterBinTree notInM0 js' - return $ (replaceJudgements mi js2) - {positions = Map.union (positions m1) (positions mi)} + return $ replaceJudgements mi js2 _ -> return mi -- add the instance opens to an incomplete module "with" instances @@ -111,7 +110,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do [i | i <- is, notElem i infs] testErr (stat' == MSComplete || stat == MSIncomplete) ("module" +++ showIdent i +++ "remains incomplete") - ModInfo mt0 _ fs me' _ ops0 _ js ps0 <- 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,9 +122,8 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do let fs1 = fs `addOptions` fs_ -- new flags have priority let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c] let js1 = buildTree (tree2list js_ ++ js0) - let ps1 = Map.union ps_ ps0 let med1= nub (ext : infs ++ insts ++ med_) - return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 js1 ps1 + return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 js1 return (i,mi') @@ -170,9 +168,9 @@ extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old unifyAnyInfo :: Ident -> Info -> Info -> Err Info unifyAnyInfo m i j = case (i,j) of (AbsCat mc1, AbsCat mc2) -> - liftM AbsCat (unifMaybe mc1 mc2) + liftM AbsCat (unifMaybeL mc1 mc2) (AbsFun mt1 ma1 md1, AbsFun mt2 ma2 md2) -> - liftM3 AbsFun (unifMaybe mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) -- adding defs + liftM3 AbsFun (unifMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) -- adding defs (ResParam mt1 mv1, ResParam mt2 mv2) -> liftM2 ResParam (unifMaybe mt1 mt2) (unifMaybe mv1 mv2) @@ -182,12 +180,12 @@ unifyAnyInfo m i j = case (i,j) of (_, ResOverload ms t) | elem m ms -> return $ ResOverload ms t (ResOper mt1 m1, ResOper mt2 m2) -> - liftM2 ResOper (unifMaybe mt1 mt2) (unifMaybe m1 m2) + liftM2 ResOper (unifMaybeL mt1 mt2) (unifMaybeL m1 m2) (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> - liftM3 CncCat (unifMaybe mc1 mc2) (unifMaybe mf1 mf2) (unifMaybe mp1 mp2) + liftM3 CncCat (unifMaybeL mc1 mc2) (unifMaybeL mf1 mf2) (unifMaybeL mp1 mp2) (CncFun m mt1 md1, CncFun _ mt2 md2) -> - liftM2 (CncFun m) (unifMaybe mt1 mt2) (unifMaybe md1 md2) ---- adding defs + liftM2 (CncFun m) (unifMaybeL mt1 mt2) (unifMaybeL md1 md2) ---- adding defs (AnyInd b1 m1, AnyInd b2 m2) -> do testErr (b1 == b2) $ "indirection status" @@ -205,6 +203,15 @@ unifMaybe (Just p1) (Just p2) | p1==p2 = return (Just p1) | otherwise = fail "" +-- | this is what happens when matching two values in the same module +unifMaybeL :: Eq a => Maybe (L a) -> Maybe (L a) -> Err (Maybe (L a)) +unifMaybeL Nothing Nothing = return Nothing +unifMaybeL (Just p1) Nothing = return (Just p1) +unifMaybeL Nothing (Just p2) = return (Just p2) +unifMaybeL (Just (L l1 p1)) (Just (L l2 p2)) + | p1==p2 = return (Just (L l1 p1)) + | otherwise = fail "" + unifAbsArrity :: Maybe Int -> Maybe Int -> Err (Maybe Int) unifAbsArrity Nothing Nothing = return Nothing unifAbsArrity (Just a ) Nothing = return (Just a ) @@ -213,14 +220,8 @@ unifAbsArrity (Just a1) (Just a2) | a1==a2 = return (Just a1) | otherwise = fail "" -unifAbsDefs :: Maybe [Equation] -> Maybe [Equation] -> Err (Maybe [Equation]) +unifAbsDefs :: Maybe [L Equation] -> Maybe [L Equation] -> Err (Maybe [L Equation]) unifAbsDefs Nothing Nothing = return Nothing unifAbsDefs (Just _ ) Nothing = fail "" unifAbsDefs Nothing (Just _ ) = fail "" unifAbsDefs (Just xs) (Just ys) = return (Just (xs ++ ys)) - -unifConstrs :: Maybe [Term] -> Maybe [Term] -> Err (Maybe [Term]) -unifConstrs p1 p2 = case (p1,p2) of - (Nothing, _) -> return p2 - (_, Nothing) -> return p1 - (Just bs, Just ds) -> return $ Just $ bs ++ ds diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs index 1febdcd46..ff34ae38a 100644 --- a/src/compiler/GF/Grammar/Binary.hs +++ b/src/compiler/GF/Grammar/Binary.hs @@ -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,positions mi) - get = do (mtype,mstatus,flags,extend,mwith,opens,med,jments,positions) <- get - return (ModInfo mtype mstatus flags extend mwith opens med jments positions) + 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) instance Binary ModuleType where put MTAbstract = putWord8 0 @@ -109,6 +109,10 @@ instance Binary Info where 8 -> get >>= \(x,y) -> return (AnyInd x y) _ -> decodingError +instance Binary a => Binary (L a) where + put (L x y) = put (x,y) + get = get >>= \(x,y) -> return (L x y) + instance Binary BindType where put Explicit = putWord8 0 put Implicit = putWord8 1 @@ -258,6 +262,6 @@ 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 Map.empty) + return (m,ModInfo mtype mstatus flags extend mwith opens med Map.empty) decodingError = fail "This GFO file was compiled with different version of GF" diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs index e883d0552..06f67234b 100644 --- a/src/compiler/GF/Grammar/CF.hs +++ b/src/compiler/GF/Grammar/CF.hs @@ -50,9 +50,9 @@ getCFRule :: String -> Err [CFRule] getCFRule s = getcf (wrds s) where getcf ws = case ws of fun : cat : a : its | isArrow a -> - Ok [(init fun, (cat, map mkIt its))] + Ok [L (0,0) (init fun, (cat, map mkIt its))] cat : a : its | isArrow a -> - Ok [(mkFun cat it, (cat, map mkIt it)) | it <- chunk its] + Ok [L (0,0) (mkFun cat it, (cat, map mkIt it)) | it <- chunk its] _ -> Bad (" invalid rule:" +++ s) isArrow a = elem a ["->", "::="] mkIt w = case w of @@ -69,7 +69,7 @@ getCFRule s = getcf (wrds s) where type CF = [CFRule] -type CFRule = (CFFun, (CFCat, [CFItem])) +type CFRule = L (CFFun, (CFCat, [CFItem])) type CFItem = Either CFCat String @@ -97,27 +97,27 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where abs = cats ++ funs conc = lincats ++ lins cat = case rules of - (_,(c,_)):_ -> c -- the value category of the first rule + (L _ (_,(c,_))):_ -> c -- the value category of the first rule _ -> error "empty CF" - cats = [(cat, AbsCat (Just [])) | + cats = [(cat, AbsCat (Just (L (0,0) []))) | cat <- nub (concat (map cf2cat rules))] ----notPredef cat - lincats = [(cat, CncCat (Just defLinType) Nothing Nothing) | (cat,AbsCat _) <- cats] + lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats] (funs,lins) = unzip (map cf2rule rules) cf2cat :: CFRule -> [Ident] -cf2cat (_,(cat, items)) = map identS $ cat : [c | Left c <- items] +cf2cat (L loc (_,(cat, items))) = map identS $ cat : [c | Left c <- items] cf2rule :: CFRule -> ((Ident,Info),(Ident,Info)) -cf2rule (fun, (cat, items)) = (def,ldef) where +cf2rule (L loc (fun, (cat, items))) = (def,ldef) where f = identS fun - def = (f, AbsFun (Just (mkProd args' (Cn (identS cat)) [])) Nothing Nothing) + def = (f, AbsFun (Just (L loc (mkProd args' (Cn (identS cat)) []))) Nothing Nothing) args0 = zip (map (identS . ("x" ++) . show) [0..]) items args = [((Explicit,v), Cn (identS c)) | (v, Left c) <- args0] args' = [(Explicit,identS "_", Cn (identS c)) | (_, Left c) <- args0] ldef = (f, CncFun Nothing - (Just (mkAbs (map fst args) - (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)]))) + (Just (L loc (mkAbs (map fst args) + (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)])))) Nothing) mkIt (v, Left _) = P (Vr v) theLinLabel mkIt (_, Right a) = K a diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index 371e0ac08..4aa2ace51 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -20,6 +20,7 @@ module GF.Grammar.Grammar (SourceGrammar, SourceModule, mapSourceModule, Info(..), + L(..), unLoc, Type, Cat, Fun, @@ -75,24 +76,33 @@ mapSourceModule f (i,mi) = (i, f mi) -- and indirection to module (/INDIR/) data Info = -- judgements in abstract syntax - AbsCat (Maybe Context) - | AbsFun (Maybe Type) (Maybe Int) (Maybe [Equation]) -- ^ (/ABS/) type, arrity and definition of function + AbsCat (Maybe (L Context)) -- ^ (/ABS/) context of a category + | AbsFun (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) -- ^ (/ABS/) type, arrity and definition of a function -- judgements in resource - | ResParam (Maybe [Param]) (Maybe [Term]) -- ^ (/RES/) the second parameter is list of all possible values - | ResValue Type -- ^ (/RES/) to mark parameter constructors for lookup - | ResOper (Maybe Type) (Maybe Term) -- ^ (/RES/) + | 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/) - | ResOverload [Ident] [(Type,Term)] -- ^ (/RES/) idents: modules inherited + | ResOverload [Ident] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited -- judgements in concrete syntax - | CncCat (Maybe Type) (Maybe Term) (Maybe Term) -- ^ (/CNC/) lindef ini'zed, - | CncFun (Maybe (Ident,Context,Type)) (Maybe Term) (Maybe Term) -- ^ (/CNC/) type info added at 'TC' + | CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) -- ^ (/CNC/) lindef ini'zed, + | CncFun (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) -- ^ (/CNC/) type info added at 'TC' -- indirection to module Ident | AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical deriving Show +data L a = L (Int,Int) a -- location information + deriving (Eq,Show) + +instance Functor L where + fmap f (L loc x) = L loc (f x) + +unLoc :: L a -> a +unLoc (L _ x) = x + type Type = Term type Cat = QIdent type Fun = QIdent diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs index 14f1ab498..90d8263cd 100644 --- a/src/compiler/GF/Grammar/Lookup.hs +++ b/src/compiler/GF/Grammar/Lookup.hs @@ -67,13 +67,13 @@ lookupResDef gr m c mo <- lookupModule gr m info <- lookupIdentInfo mo c case info of - ResOper _ (Just t) -> return t + ResOper _ (Just (L _ t)) -> return t ResOper _ Nothing -> return (Q m c) - CncCat (Just ty) _ _ -> lock c ty + CncCat (Just (L _ ty)) _ _ -> lock c ty CncCat _ _ _ -> lock c defLinType - CncFun (Just (cat,_,_)) (Just tr) _ -> unlock cat tr - CncFun _ (Just tr) _ -> return tr + CncFun (Just (cat,_,_)) (Just (L _ tr)) _ -> unlock cat tr + CncFun _ (Just (L _ tr)) _ -> return tr AnyInd _ n -> look n c ResParam _ _ -> return (QC m c) @@ -85,7 +85,7 @@ lookupResType gr m c = do mo <- lookupModule gr m info <- lookupIdentInfo mo c case info of - ResOper (Just t) _ -> return t + ResOper (Just (L _ t)) _ -> return t -- used in reused concrete CncCat _ _ _ -> return typeType @@ -94,7 +94,7 @@ lookupResType gr m c = do return $ mkProd cont val' [] AnyInd _ n -> lookupResType gr n c ResParam _ _ -> return typePType - ResValue t -> return t + ResValue (L _ t) -> return t _ -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m) lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))] @@ -105,7 +105,7 @@ lookupOverload gr m c = do ResOverload os tysts -> do tss <- mapM (\x -> lookupOverload gr x c) os return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) | - (ty,tr) <- tysts] ++ + (L _ ty,L _ tr) <- tysts] ++ concat tss AnyInd _ n -> lookupOverload gr n c @@ -153,7 +153,7 @@ lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) mo <- lookupModule gr m info <- lookupIdentInfo mo c case info of - AbsFun _ a d -> return (a,d) + AbsFun _ a d -> return (a,fmap (map unLoc) d) AnyInd _ n -> lookupAbsDef gr n c _ -> return (Nothing,Nothing) @@ -163,9 +163,9 @@ lookupLincat gr m c = do mo <- lookupModule gr m info <- lookupIdentInfo mo c case info of - CncCat (Just t) _ _ -> return t - AnyInd _ n -> lookupLincat gr n c - _ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m)) + CncCat (Just (L _ t)) _ _ -> return t + AnyInd _ n -> lookupLincat gr n c + _ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m)) -- | this is needed at compile time lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type @@ -173,9 +173,9 @@ lookupFunType gr m c = do mo <- lookupModule gr m info <- lookupIdentInfo mo c case info of - AbsFun (Just t) _ _ -> return t - AnyInd _ n -> lookupFunType gr n c - _ -> Bad (render (text "cannot find type of" <+> ppIdent c)) + AbsFun (Just (L _ t)) _ _ -> return t + AnyInd _ n -> lookupFunType gr n c + _ -> Bad (render (text "cannot find type of" <+> ppIdent c)) -- | this is needed at compile time lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context @@ -183,6 +183,6 @@ lookupCatContext gr m c = do mo <- lookupModule gr m info <- lookupIdentInfo mo c case info of - AbsCat (Just co) -> return co - AnyInd _ n -> lookupCatContext gr n c - _ -> Bad (render (text "unknown category" <+> ppIdent c)) + AbsCat (Just (L _ co)) -> return co + AnyInd _ n -> lookupCatContext gr n c + _ -> Bad (render (text "unknown category" <+> ppIdent c)) diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index ef68b740d..5282b30b1 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -607,15 +607,15 @@ allDependencies ism b = Q n c | ism n -> [c] QC n c | ism n -> [c] _ -> collectOp opersIn t - opty (Just ty) = opersIn ty + opty (Just (L _ ty)) = opersIn ty opty _ = [] pts i = case i of ResOper pty pt -> [pty,pt] - ResParam (Just ps) _ -> [Just t | (_,cont) <- ps, (_,_,t) <- cont] + ResParam (Just ps) _ -> [Just (L loc t) | L loc (_,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 - AbsCat (Just co) -> [Just ty | (_,_,ty) <- co] + AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co] _ -> [] topoSortJments :: SourceModule -> Err [(Ident,Info)] diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y index 2346953a9..16cea88b8 100644 --- a/src/compiler/GF/Grammar/Parser.y +++ b/src/compiler/GF/Grammar/Parser.y @@ -113,23 +113,17 @@ ModDef (extends,with,content) = $4 (opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) } mapM_ (checkInfoType mtype) jments - defs <- case buildAnyTree id [(i,d) | (i,_,d) <- jments] of + defs <- case buildAnyTree id jments of Ok x -> return x Bad msg -> fail msg - let poss = buildTree [(i,(fname,mkSrcSpan p)) | (i,p,_) <- jments] - fname = showIdent id ++ ".gf" - - mkSrcSpan :: (Posn, Posn) -> (Int,Int) - mkSrcSpan (Pn l1 _, Pn l2 _) = (l1,l2) - - return (id, ModInfo mtype mstat opts extends with opens [] defs poss) } + 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 emptyBinTree) } + in (id, ModInfo mtype mstat noOptions extends with opens [] emptyBinTree) } ComplMod :: { ModuleStatus } ComplMod @@ -164,7 +158,7 @@ ModOpen ModBody :: { ( [(Ident,MInclude)] , Maybe (Ident,MInclude,[(Ident,Ident)]) - , Maybe ([OpenSpec],[(Ident,SrcSpan,Info)],Options) + , Maybe ([OpenSpec],[(Ident,Info)],Options) ) } ModBody : ListIncluded '**' Included 'with' ListInst '**' ModContent { ($1, Just (fst $3,snd $3,$5), Just $7) } @@ -176,12 +170,12 @@ ModBody | ModContent { ([], Nothing, Just $1) } | ModBody ';' { $1 } -ModContent :: { ([OpenSpec],[(Ident,SrcSpan,Info)],Options) } +ModContent :: { ([OpenSpec],[(Ident,Info)],Options) } ModContent : '{' ListTopDef '}' { ([],[d | Left ds <- $2, d <- ds],concatOptions [o | Right o <- $2]) } | 'open' ListOpen 'in' '{' ListTopDef '}' { ($2,[d | Left ds <- $5, d <- ds],concatOptions [o | Right o <- $5]) } -ListTopDef :: { [Either [(Ident,SrcSpan,Info)] Options] } +ListTopDef :: { [Either [(Ident,Info)] Options] } ListTopDef : {- empty -} { [] } | TopDef ListTopDef { $1 : $2 } @@ -216,7 +210,7 @@ Included | Ident '[' ListIdent ']' { ($1,MIOnly $3) } | Ident '-' '[' ListIdent ']' { ($1,MIExcept $4) } -TopDef :: { Either [(Ident,SrcSpan,Info)] Options } +TopDef :: { Either [(Ident,Info)] Options } TopDef : 'cat' ListCatDef { Left $2 } | 'fun' ListFunDef { Left $2 } @@ -224,56 +218,56 @@ TopDef | 'data' ListDataDef { Left $2 } | 'param' ListParamDef { Left $2 } | 'oper' ListOperDef { Left $2 } - | 'lincat' ListTermDef { Left [(f, pos, CncCat (Just e) Nothing Nothing ) | (f,pos,e) <- $2] } - | 'lindef' ListTermDef { Left [(f, pos, CncCat Nothing (Just e) Nothing ) | (f,pos,e) <- $2] } + | 'lincat' ListTermDef { Left [(f, CncCat (Just e) Nothing Nothing ) | (f,e) <- $2] } + | 'lindef' ListTermDef { Left [(f, CncCat Nothing (Just e) Nothing ) | (f,e) <- $2] } | 'lin' ListLinDef { Left $2 } - | 'printname' 'cat' ListTermDef { Left [(f, pos, CncCat Nothing Nothing (Just e)) | (f,pos,e) <- $3] } - | 'printname' 'fun' ListTermDef { Left [(f, pos, CncFun Nothing Nothing (Just e)) | (f,pos,e) <- $3] } + | 'printname' 'cat' ListTermDef { Left [(f, CncCat Nothing Nothing (Just e)) | (f,e) <- $3] } + | 'printname' 'fun' ListTermDef { Left [(f, CncFun Nothing Nothing (Just e)) | (f,e) <- $3] } | 'flags' ListFlagDef { Right $2 } -CatDef :: { [(Ident,SrcSpan,Info)] } +CatDef :: { [(Ident,Info)] } CatDef - : Posn Ident ListDDecl Posn { [($2, ($1,$4), AbsCat (Just $3))] } - | Posn '[' Ident ListDDecl ']' Posn { listCatDef $3 ($1,$6) $4 0 } - | Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef $3 ($1,$9) $4 (fromIntegral $7) } + : Posn Ident ListDDecl Posn { [($2, AbsCat (Just (mkL $1 $4 $3)))] } + | Posn '[' Ident ListDDecl ']' Posn { listCatDef (mkL $1 $6 ($3,$4,0)) } + | Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef (mkL $1 $9 ($3,$4,fromIntegral $7)) } -FunDef :: { [(Ident,SrcSpan,Info)] } +FunDef :: { [(Ident,Info)] } FunDef - : Posn ListIdent ':' Exp Posn { [(fun, ($1,$5), AbsFun (Just $4) Nothing (Just [])) | fun <- $2] } + : Posn ListIdent ':' Exp Posn { [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing (Just [])) | fun <- $2] } -DefDef :: { [(Ident,SrcSpan,Info)] } +DefDef :: { [(Ident,Info)] } DefDef - : Posn ListName '=' Exp Posn { [(f, ($1,$5),AbsFun Nothing (Just 0) (Just [([],$4)])) | f <- $2] } - | Posn Name ListPatt '=' Exp Posn { [($2,($1,$6),AbsFun Nothing (Just (length $3)) (Just [($3,$5)]))] } + : Posn ListName '=' Exp Posn { [(f, AbsFun Nothing (Just 0) (Just [mkL $1 $5 ([],$4)])) | f <- $2] } + | Posn Name ListPatt '=' Exp Posn { [($2,AbsFun Nothing (Just (length $3)) (Just [mkL $1 $6 ($3,$5)]))] } -DataDef :: { [(Ident,SrcSpan,Info)] } +DataDef :: { [(Ident,Info)] } DataDef - : Posn Ident '=' ListDataConstr Posn { ($2, ($1,$5), AbsCat Nothing) : - [(fun, ($1,$5), AbsFun Nothing Nothing Nothing) | fun <- $4] } - | Posn ListIdent ':' Exp Posn { -- (snd (valCat $4), ($1,$5), AbsCat Nothing) : - [(fun, ($1,$5), AbsFun (Just $4) Nothing Nothing) | fun <- $2] } + : Posn Ident '=' ListDataConstr Posn { ($2, AbsCat Nothing) : + [(fun, AbsFun Nothing Nothing Nothing) | fun <- $4] } + | Posn ListIdent ':' Exp Posn { -- (snd (valCat $4), AbsCat Nothing) : + [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing Nothing) | fun <- $2] } -ParamDef :: { [(Ident,SrcSpan,Info)] } +ParamDef :: { [(Ident,Info)] } ParamDef - : Posn Ident '=' ListParConstr Posn { ($2, ($1,$5), ResParam (Just $4) Nothing) : - [(f, ($1,$5), ResValue (mkProdSimple co (Cn $2))) | (f,co) <- $4] } - | Posn Ident Posn { [($2, ($1,$3), ResParam Nothing Nothing)] } + : 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)] } -OperDef :: { [(Ident,SrcSpan,Info)] } +OperDef :: { [(Ident,Info)] } OperDef - : Posn ListName ':' Exp Posn { [(i, ($1,$5), info) | i <- $2, info <- mkOverload (Just $4) Nothing ] } - | Posn ListName '=' Exp Posn { [(i, ($1,$5), info) | i <- $2, info <- mkOverload Nothing (Just $4)] } - | Posn Name ListArg '=' Exp Posn { [(i, ($1,$6), info) | i <- [$2], info <- mkOverload Nothing (Just (mkAbs $3 $5))] } - | Posn ListName ':' Exp '=' Exp Posn { [(i, ($1,$7), info) | i <- $2, info <- mkOverload (Just $4) (Just $6)] } + : Posn ListName ':' Exp Posn { [(i, info) | i <- $2, info <- mkOverload (Just (mkL $1 $5 $4)) Nothing ] } + | Posn ListName '=' Exp Posn { [(i, info) | i <- $2, info <- mkOverload Nothing (Just (mkL $1 $5 $4))] } + | Posn Name ListArg '=' Exp Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing (Just (mkL $1 $6 (mkAbs $3 $5)))] } + | Posn ListName ':' Exp '=' Exp Posn { [(i, info) | i <- $2, info <- mkOverload (Just (mkL $1 $7 $4)) (Just (mkL $1 $7 $6))] } -LinDef :: { [(Ident,SrcSpan,Info)] } +LinDef :: { [(Ident,Info)] } LinDef - : Posn ListName '=' Exp Posn { [(f, ($1,$5), CncFun Nothing (Just $4) Nothing) | f <- $2] } - | Posn Name ListArg '=' Exp Posn { [($2, ($1,$6), CncFun Nothing (Just (mkAbs $3 $5)) Nothing)] } + : Posn ListName '=' Exp Posn { [(f, CncFun Nothing (Just (mkL $1 $5 $4)) Nothing) | f <- $2] } + | Posn Name ListArg '=' Exp Posn { [($2, CncFun Nothing (Just (mkL $1 $6 (mkAbs $3 $5))) Nothing)] } -TermDef :: { [(Ident,SrcSpan,Term)] } +TermDef :: { [(Ident,L Term)] } TermDef - : Posn ListName '=' Exp Posn { [(i,($1,$5),$4) | i <- $2] } + : Posn ListName '=' Exp Posn { [(i,mkL $1 $5 $4) | i <- $2] } FlagDef :: { Options } FlagDef @@ -286,46 +280,46 @@ ListDataConstr : Ident { [$1] } | Ident '|' ListDataConstr { $1 : $3 } -ParConstr :: { Param } +ParConstr :: { L Param } ParConstr - : Ident ListDDecl { ($1,$2) } + : Posn Ident ListDDecl Posn { mkL $1 $4 ($2,$3) } -ListLinDef :: { [(Ident,SrcSpan,Info)] } +ListLinDef :: { [(Ident,Info)] } ListLinDef : LinDef ';' { $1 } | LinDef ';' ListLinDef { $1 ++ $3 } -ListDefDef :: { [(Ident,SrcSpan,Info)] } +ListDefDef :: { [(Ident,Info)] } ListDefDef : DefDef ';' { $1 } | DefDef ';' ListDefDef { $1 ++ $3 } -ListOperDef :: { [(Ident,SrcSpan,Info)] } +ListOperDef :: { [(Ident,Info)] } ListOperDef : OperDef ';' { $1 } | OperDef ';' ListOperDef { $1 ++ $3 } -ListCatDef :: { [(Ident,SrcSpan,Info)] } +ListCatDef :: { [(Ident,Info)] } ListCatDef : CatDef ';' { $1 } | CatDef ';' ListCatDef { $1 ++ $3 } -ListFunDef :: { [(Ident,SrcSpan,Info)] } +ListFunDef :: { [(Ident,Info)] } ListFunDef : FunDef ';' { $1 } | FunDef ';' ListFunDef { $1 ++ $3 } -ListDataDef :: { [(Ident,SrcSpan,Info)] } +ListDataDef :: { [(Ident,Info)] } ListDataDef : DataDef ';' { $1 } | DataDef ';' ListDataDef { $1 ++ $3 } -ListParamDef :: { [(Ident,SrcSpan,Info)] } +ListParamDef :: { [(Ident,Info)] } ListParamDef : ParamDef ';' { $1 } | ParamDef ';' ListParamDef { $1 ++ $3 } -ListTermDef :: { [(Ident,SrcSpan,Term)] } +ListTermDef :: { [(Ident,L Term)] } ListTermDef : TermDef ';' { $1 } | TermDef ';' ListTermDef { $1 ++ $3 } @@ -335,7 +329,7 @@ ListFlagDef : FlagDef ';' { $1 } | FlagDef ';' ListFlagDef { addOptions $1 $3 } -ListParConstr :: { [Param] } +ListParConstr :: { [L Param] } ListParConstr : ParConstr { [$1] } | ParConstr '|' ListParConstr { $1 : $3 } @@ -620,16 +614,16 @@ mkBaseId = prefixId (BS.pack "Base") prefixId :: BS.ByteString -> Ident -> Ident prefixId pref id = identC (BS.append pref (ident2bs id)) -listCatDef :: Ident -> SrcSpan -> Context -> Int -> [(Ident,SrcSpan,Info)] -listCatDef id pos cont size = [catd,nilfund,consfund] +listCatDef :: L (Ident, Context, Int) -> [(Ident,Info)] +listCatDef (L loc (id,cont,size)) = [catd,nilfund,consfund] where listId = mkListId id baseId = mkBaseId id consId = mkConsId id - catd = (listId, pos, AbsCat (Just cont')) - nilfund = (baseId, pos, AbsFun (Just niltyp) Nothing Nothing) - consfund = (consId, pos, AbsFun (Just constyp) Nothing Nothing) + catd = (listId, AbsCat (Just (L loc cont'))) + nilfund = (baseId, AbsFun (Just (L loc niltyp)) Nothing Nothing) + consfund = (consId, AbsFun (Just (L loc constyp)) Nothing Nothing) cont' = [(b,mkId x i,ty) | (i,(b,x,ty)) <- zip [0..] cont] xs = map (\(b,x,t) -> Vr x) cont' @@ -656,16 +650,16 @@ mkR fs@(f:_) = tryR (lab,mty,Just t) = return (ident2label lab,(mty,t)) tryR (lab,_ ,_ ) = fail $ "illegal record field" +++ showIdent lab -mkOverload pdt pdf@(Just df) = +mkOverload pdt pdf@(Just (L loc df)) = case appForm df of (keyw, ts@(_:_)) | isOverloading keyw -> case last ts of - R fs -> [ResOverload [m | Vr m <- ts] [(ty,fu) | (_,(Just ty,fu)) <- fs]] + R fs -> [ResOverload [m | Vr m <- ts] [(L loc ty,L loc fu) | (_,(Just ty,fu)) <- fs]] _ -> [ResOper pdt pdf] _ -> [ResOper pdt pdf] -- to enable separare type signature --- not type-checked -mkOverload pdt@(Just df) pdf = +mkOverload pdt@(Just (L _ df)) pdf = case appForm df of (keyw, ts@(_:_)) | isOverloading keyw -> case last ts of @@ -680,29 +674,26 @@ isOverloading t = _ -> False -type SrcSpan = (Posn,Posn) - - -checkInfoType MTAbstract (id,pos,info) = +checkInfoType MTAbstract (id,info) = case info of AbsCat _ -> return () AbsFun _ _ _ -> return () - _ -> failLoc (fst pos) "illegal definition in abstract module" -checkInfoType MTResource (id,pos,info) = + _ -> failLoc (getInfoPos info) "illegal definition in abstract module" +checkInfoType MTResource (id,info) = case info of ResParam _ _ -> return () ResValue _ -> return () ResOper _ _ -> return () ResOverload _ _ -> return () - _ -> failLoc (fst pos) "illegal definition in resource module" -checkInfoType MTInterface (id,pos,info) = + _ -> failLoc (getInfoPos info) "illegal definition in resource module" +checkInfoType MTInterface (id,info) = case info of ResParam _ _ -> return () ResValue _ -> return () ResOper _ _ -> return () ResOverload _ _ -> return () - _ -> failLoc (fst pos) "illegal definition in interface module" -checkInfoType (MTConcrete _) (id,pos,info) = + _ -> failLoc (getInfoPos info) "illegal definition in interface module" +checkInfoType (MTConcrete _) (id,info) = case info of CncCat _ _ _ -> return () CncFun _ _ _ -> return () @@ -710,14 +701,15 @@ checkInfoType (MTConcrete _) (id,pos,info) = ResValue _ -> return () ResOper _ _ -> return () ResOverload _ _ -> return () - _ -> failLoc (fst pos) "illegal definition in concrete module" -checkInfoType (MTInstance _) (id,pos,info) = + _ -> failLoc (getInfoPos info) "illegal definition in concrete module" +checkInfoType (MTInstance _) (id,info) = case info of ResParam _ _ -> return () ResValue _ -> return () ResOper _ _ -> return () - _ -> failLoc (fst pos) "illegal definition in instance module" + _ -> failLoc (getInfoPos info) "illegal definition in instance module" +getInfoPos = undefined mkAlts cs = case cs of _:_ -> do @@ -741,5 +733,7 @@ mkAlts cs = case cs of PM m c -> return (Q m c) --- for macros; not yet complete _ -> fail "no strs from pattern" -} +mkL :: Posn -> Posn -> x -> L x +mkL (Pn l1 _) (Pn l2 _) x = L (l1,l2) x +} \ No newline at end of file diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index 15afef865..1db1eb4f3 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -16,6 +16,7 @@ module GF.Grammar.Printer , ppPatt , ppValue , ppConstrs + , ppPosition ) where import GF.Infra.Ident @@ -32,7 +33,7 @@ import qualified Data.Map as Map data TermPrintQual = Qualified | Unqualified 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 @@ -74,15 +75,15 @@ ppOptions opts = ppJudgement q (id, AbsCat pcont ) = text "cat" <+> ppIdent id <+> (case pcont of - Just cont -> hsep (map (ppDecl q) cont) - Nothing -> empty) <+> semi + Just (L _ cont) -> hsep (map (ppDecl q) cont) + Nothing -> empty) <+> semi ppJudgement q (id, AbsFun ptype _ pexp) = (case ptype of - Just typ -> text (if isNothing pexp then "data" else "fun") <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi - Nothing -> empty) $$ + Just (L _ typ) -> text (if isNothing pexp then "data" else "fun") <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi + Nothing -> empty) $$ (case pexp of Just [] -> empty - Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | (ps,e) <- eqs] + Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | L _ (ps,e) <- eqs] Nothing -> empty) ppJudgement q (id, ResParam pparams _) = text "param" <+> ppIdent id <+> @@ -92,31 +93,31 @@ ppJudgement q (id, ResParam pparams _) = ppJudgement q (id, ResValue pvalue) = empty ppJudgement q (id, ResOper ptype pexp) = text "oper" <+> ppIdent id <+> - (case ptype of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} $$ - case pexp of {Just e -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi + (case ptype of {Just (L _ t) -> colon <+> ppTerm q 0 t; Nothing -> empty} $$ + case pexp of {Just (L _ e) -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi ppJudgement q (id, ResOverload ids defs) = text "oper" <+> ppIdent id <+> equals <+> (text "overload" <+> lbrace $$ - nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e) | (ty,e) <- defs]) $$ + nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e) | (L _ ty,L _ e) <- defs]) $$ rbrace) <+> semi ppJudgement q (id, CncCat ptype pexp pprn) = (case ptype of - Just typ -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi - Nothing -> empty) $$ + Just (L _ typ) -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi + Nothing -> empty) $$ (case pexp of - Just exp -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi - Nothing -> empty) $$ + Just (L _ exp) -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi + Nothing -> empty) $$ (case pprn of - Just prn -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi - Nothing -> empty) + Just (L _ prn) -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi + Nothing -> empty) ppJudgement q (id, CncFun ptype pdef pprn) = (case pdef of - Just e -> let (xs,e') = getAbs e - in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi - Nothing -> empty) $$ + Just (L _ e) -> let (xs,e') = getAbs e + in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi + Nothing -> empty) $$ (case pprn of - Just prn -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi - Nothing -> empty) + Just (L _ prn) -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi + Nothing -> empty) ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e) @@ -257,7 +258,12 @@ ppBind (Implicit,v) = braces (ppIdent v) ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y -ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt) +ppParam q (L _ (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 commaPunct f ds = (hcat (punctuate comma (map f ds))) diff --git a/src/compiler/GF/Infra/Modules.hs b/src/compiler/GF/Infra/Modules.hs index 40941c398..af930f881 100644 --- a/src/compiler/GF/Infra/Modules.hs +++ b/src/compiler/GF/Infra/Modules.hs @@ -32,7 +32,6 @@ module GF.Infra.Modules ( emptyMGrammar, emptyModInfo, abstractOfConcrete, abstractModOfConcrete, lookupModule, lookupModuleType, lookupInfo, - lookupPosition, ppPosition, isModAbs, isModRes, isModCnc, sameMType, isCompilableModule, isCompleteModule, allAbstracts, greatestAbstract, allResources, @@ -64,8 +63,7 @@ data ModInfo a = ModInfo { mwith :: Maybe (Ident,MInclude,[(Ident,Ident)]), opens :: [OpenSpec], mexdeps :: [Ident], - jments :: Map.Map Ident a, - positions :: Map.Map Ident (String,(Int,Int)) -- file, first line, last line + jments :: Map.Map Ident a } deriving Show @@ -105,13 +103,13 @@ updateMGrammar old new = MGrammar $ ns = modules new updateModule :: ModInfo t -> Ident -> t -> ModInfo t -updateModule (ModInfo mt ms fs me mw ops med js ps) i t = ModInfo mt ms fs me mw ops med (updateTree (i,t) js) ps +updateModule (ModInfo mt ms fs me mw ops med js) i t = ModInfo mt ms fs me mw ops med (updateTree (i,t) js) replaceJudgements :: ModInfo t -> Map.Map Ident t -> ModInfo t -replaceJudgements (ModInfo mt ms fs me mw ops med _ ps) js = ModInfo mt ms fs me mw ops med js ps +replaceJudgements (ModInfo mt ms fs me mw ops med _) js = ModInfo mt ms fs me mw ops med js addOpenQualif :: Ident -> Ident -> ModInfo t -> ModInfo t -addOpenQualif i j (ModInfo mt ms fs me mw ops med js ps) = ModInfo mt ms fs me mw (OQualif i j : ops) med js ps +addOpenQualif i j (ModInfo mt ms fs me mw ops med js) = ModInfo mt ms fs me mw (OQualif i j : ops) med js addFlag :: Options -> ModInfo t -> ModInfo t addFlag f mo = mo {flags = flags mo `addOptions` f} @@ -216,7 +214,7 @@ emptyMGrammar :: MGrammar a emptyMGrammar = MGrammar [] emptyModInfo :: ModInfo a -emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree emptyBinTree +emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree -- | we store the module type with the identifier @@ -250,15 +248,6 @@ lookupModuleType gr m = do lookupInfo :: ModInfo a -> Ident -> Err a lookupInfo mo i = lookupTree showIdent i (jments mo) -lookupPosition :: ModInfo a -> Ident -> Err (String,(Int,Int)) -lookupPosition mo i = lookupTree showIdent i (positions mo) - -ppPosition :: ModInfo a -> Ident -> Doc -ppPosition mo i = case lookupPosition mo i of - Ok (f,(b,e)) | b == e -> text "in" <+> text f <> text ", line" <+> int b - | otherwise -> text "in" <+> text f <> text ", lines" <+> int b <> text "-" <> int e - _ -> empty - isModAbs :: ModInfo a -> Bool isModAbs m = case mtype m of diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs index 84bfc43c5..e80403145 100644 --- a/src/compiler/GFI.hs +++ b/src/compiler/GFI.hs @@ -120,7 +120,7 @@ loop opts gfenv0 = do (style,q,s) = pOpts TermPrintDefault Qualified (tail (words s0)) - checkComputeTerm gr t = do + checkComputeTerm gr (L _ t) = do mo <- maybe (Bad "no source grammar in scope") return $ greatestResource gr ((t,_),_) <- runCheck $ do t <- renameSourceTerm gr mo t inferLType gr [] t @@ -128,7 +128,7 @@ loop opts gfenv0 = do case runP pExp (BS.pack s) of Left (_,msg) -> putStrLn msg - Right t -> case checkComputeTerm sgr (codeTerm (decode gfenv) t) of + Right t -> case checkComputeTerm sgr (codeTerm (decode gfenv) (L (0,0) t)) of Ok x -> putStrLn $ enc (showTerm sgr style q x) Bad s -> putStrLn $ enc s loopNewCPU gfenv