diff --git a/src/compiler/GF.hs b/src/compiler/GF.hs index 43a2a0b7f..bb68f5de6 100644 --- a/src/compiler/GF.hs +++ b/src/compiler/GF.hs @@ -3,6 +3,7 @@ module Main where import GFC import GFI +import GFTags import GF.Data.ErrM import GF.Infra.Option import GF.Infra.UseIO @@ -47,3 +48,4 @@ mainOpts opts files = ModeRun -> mainRunGFI opts files ModeServer -> mainServerGFI opts files ModeCompiler -> dieIOE (mainGFC opts files) + ModeTags -> dieIOE (mainTags opts files) diff --git a/src/compiler/GF/Command/Importing.hs b/src/compiler/GF/Command/Importing.hs index cbbb7a30e..d8b7f0e0c 100644 --- a/src/compiler/GF/Command/Importing.hs +++ b/src/compiler/GF/Command/Importing.hs @@ -55,12 +55,11 @@ importSource src0 opts files = do -- for different cf formats importCF opts files get = do s <- fmap unlines $ mapM readFile files - let cnc = justModuleName (last files) - gf <- case get cnc s of - Ok g -> return g + gf <- case get (last files) s of + Ok gf -> return gf Bad s -> error s ---- Ok gr <- appIOE $ compileSourceGrammar opts gf - epgf <- appIOE $ link opts (identC (BS.pack (cnc ++ "Abs"))) gr + epgf <- appIOE $ link opts (identC (BS.pack (justModuleName (last files) ++ "Abs"))) gr case epgf of Ok pgf -> return pgf - Bad s -> error s ---- + Bad s -> error s ---- diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index 4ab4a986a..5b3abb98c 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -70,12 +70,11 @@ batchCompile opts files = do -- to compile a set of modules, e.g. an old GF or a .cf file compileSourceGrammar :: Options -> SourceGrammar -> IOE SourceGrammar compileSourceGrammar opts gr = do - (_,gr',_) <- foldM compOne (0,emptySourceGrammar,Map.empty) (modules gr) + (_,gr',_) <- foldM (\env -> compileSourceModule opts env Nothing) + (0,emptySourceGrammar,Map.empty) + (modules gr) return gr' - where - compOne env mo = do - (k,mo') <- compileSourceModule opts env mo - extendCompileEnvInt env k Nothing mo' --- file for the same of modif time... + -- to output an intermediate stage intermOut :: Options -> Dump -> Doc -> IOE () @@ -161,18 +160,16 @@ compileOne opts env@(_,srcgr,_) file = do sm00 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ getSourceModule opts file enc <- ioeIO $ mkTextEncoding (renameEncoding (flag optEncoding (flagsModule sm00))) - let sm0 = decodeStringsInModule enc sm00 + let sm = decodeStringsInModule enc sm00 - intermOut opts DumpSource (ppModule Qualified sm0) + intermOut opts DumpSource (ppModule Qualified sm) - (k',sm) <- compileSourceModule opts env sm0 - putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo sm - extendCompileEnvInt env k' (Just gfo) sm + compileSourceModule opts env (Just gfo) sm where isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete -compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule) -compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do +compileSourceModule :: Options -> CompileEnv -> Maybe FilePath -> SourceModule -> IOE CompileEnv +compileSourceModule opts env@(k,gr,_) mb_gfo mo@(i,mi) = do let puts = putPointE Quiet opts putpp = putPointE Verbose opts @@ -185,7 +182,13 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do case mo1b of (_,n) | not (isCompleteModule n) -> do - return (k,mo1b) -- refresh would fail, since not renamed + case mb_gfo of + Just gfo -> if flag optMode opts /= ModeTags + then putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo mo1b + else putStrLnE "" >> return mo1b + Nothing -> return mo1b + + extendCompileEnvInt env k mb_gfo mo1b _ -> do let mos = modules gr @@ -197,13 +200,21 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do if null warnings then return () else puts warnings $ return () intermOut opts DumpTypeCheck (ppModule Qualified mo3) - (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 - intermOut opts DumpRefresh (ppModule Qualified mo3r) + if flag optMode opts /= ModeTags + then do (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 + intermOut opts DumpRefresh (ppModule Qualified mo3r) - mo4 <- putpp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r - intermOut opts DumpOptimize (ppModule Qualified mo4) + mo4 <- putpp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r + intermOut opts DumpOptimize (ppModule Qualified mo4) + + case mb_gfo of + Just gfo -> putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo mo4 + Nothing -> return mo4 + + extendCompileEnvInt env k' mb_gfo mo4 + else do putStrLnE "" + extendCompileEnvInt env k mb_gfo mo3 - return (k',mo4) generateModuleCode :: Options -> FilePath -> SourceModule -> IOE SourceModule generateModuleCode opts file minfo = do diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index b3129128b..44e2e552b 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -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 diff --git a/src/compiler/GF/Compile/Compute/AppPredefined.hs b/src/compiler/GF/Compile/Compute/AppPredefined.hs index d15d57001..8732a8e06 100644 --- a/src/compiler/GF/Compile/Compute/AppPredefined.hs +++ b/src/compiler/GF/Compile/Compute/AppPredefined.hs @@ -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") diff --git a/src/compiler/GF/Compile/GetGrammar.hs b/src/compiler/GF/Compile/GetGrammar.hs index c7fea11b0..339f28578 100644 --- a/src/compiler/GF/Compile/GetGrammar.hs +++ b/src/compiler/GF/Compile/GetGrammar.hs @@ -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 }) diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index ed10697fd..81d2b3632 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -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]] diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index 8cd84a1a0..4c959c194 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -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) diff --git a/src/compiler/GF/Compile/SubExOpt.hs b/src/compiler/GF/Compile/SubExOpt.hs index 49d7efb81..808e4dca8 100644 --- a/src/compiler/GF/Compile/SubExOpt.hs +++ b/src/compiler/GF/Compile/SubExOpt.hs @@ -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)) diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 1dcae722c..fe9bd5984 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -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 diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs index 981037827..78ad3e53f 100644 --- a/src/compiler/GF/Grammar/Analyse.hs +++ b/src/compiler/GF/Grammar/Analyse.hs @@ -107,7 +107,7 @@ sizeInfo i = case i of AbsFun mt mi me mb -> 1 + msize mt + sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es] ResParam mp mt -> - 1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just ps <- [mp], L _ (_,co) <- ps] + 1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co) <- ps] ResValue lt -> 0 ResOper mt md -> 1 + msize mt + msize md ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs] diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs index 32ddfe6ad..7c79be361 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) - get = do (mtype,mstatus,flags,extend,mwith,opens,med,jments) <- get - return (ModInfo mtype mstatus flags extend mwith opens med jments) + put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,msrc mi,jments mi) + get = do (mtype,mstatus,flags,extend,mwith,opens,med,src,jments) <- get + return (ModInfo mtype mstatus flags extend mwith opens med src jments) instance Binary ModuleType where put MTAbstract = putWord8 0 @@ -109,6 +109,16 @@ instance Binary Info where 8 -> get >>= \(x,y) -> return (AnyInd x y) _ -> decodingError +instance Binary Location where + put NoLoc = putWord8 0 + put (Local x y) = putWord8 1 >> put (x,y) + put (External x y) = putWord8 2 >> put (x,y) + get = do tag <- getWord8 + case tag of + 0 -> return NoLoc + 1 -> get >>= \(x,y) -> return (Local x y) + 2 -> get >>= \(x,y) -> return (External x y) + instance Binary a => Binary (L a) where put (L x y) = put (x,y) get = get >>= \(x,y) -> return (L x y) @@ -261,7 +271,7 @@ instance Binary Label where decodeModHeader :: FilePath -> IO SourceModule decodeModHeader fpath = do - (m,mtype,mstatus,flags,extend,mwith,opens,med) <- decodeFile fpath - return (m,ModInfo mtype mstatus flags extend mwith opens med Map.empty) + (m,mtype,mstatus,flags,extend,mwith,opens,med,src) <- decodeFile fpath + return (m,ModInfo mtype mstatus flags extend mwith opens med src Map.empty) decodingError = fail "This GFO file was compiled with different version of GF" diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs index 93ae10b4a..10f7a71fd 100644 --- a/src/compiler/GF/Grammar/CF.hs +++ b/src/compiler/GF/Grammar/CF.hs @@ -19,15 +19,17 @@ import GF.Grammar.Macros import GF.Infra.Ident import GF.Infra.Modules import GF.Infra.Option +import GF.Infra.UseIO import GF.Data.Operations import Data.Char import Data.List import qualified Data.ByteString.Char8 as BS +import System.FilePath -getCF :: String -> String -> Err SourceGrammar -getCF name = fmap (cf2gf name) . pCF +getCF :: FilePath -> String -> Err SourceGrammar +getCF fpath = fmap (cf2gf fpath) . pCF --------------------- -- the parser ------- @@ -50,9 +52,9 @@ getCFRule :: String -> Err [CFRule] getCFRule s = getcf (wrds s) where getcf ws = case ws of fun : cat : a : its | isArrow a -> - Ok [L (0,0) (init fun, (cat, map mkIt its))] + Ok [L NoLoc (init fun, (cat, map mkIt its))] cat : a : its | isArrow a -> - Ok [L (0,0) (mkFun cat it, (cat, map mkIt it)) | it <- chunk its] + Ok [L NoLoc (mkFun cat it, (cat, map mkIt it)) | it <- chunk its] _ -> Bad (" invalid rule:" +++ s) isArrow a = elem a ["->", "::="] mkIt w = case w of @@ -80,13 +82,14 @@ type CFFun = String -- the compiler ---------- -------------------------- -cf2gf :: String -> CF -> SourceGrammar -cf2gf name cf = mGrammar [ +cf2gf :: FilePath -> CF -> SourceGrammar +cf2gf fpath cf = mGrammar [ (aname, addFlag (modifyFlags (\fs -> fs{optStartCat = Just cat})) - (emptyModInfo{mtype = MTAbstract, jments = abs})), - (cname, emptyModInfo{mtype = MTConcrete aname, jments = cnc}) + (emptyModInfo{mtype = MTAbstract, msrc=fpath, jments = abs})), + (cname, emptyModInfo{mtype = MTConcrete aname, msrc=fpath, jments = cnc}) ] where + name = justModuleName fpath (abs,cnc,cat) = cf2grammar cf aname = identS $ name ++ "Abs" cname = identS name @@ -99,7 +102,7 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where cat = case rules of (L _ (_,(c,_))):_ -> c -- the value category of the first rule _ -> error "empty CF" - cats = [(cat, AbsCat (Just (L (0,0) []))) | + cats = [(cat, AbsCat (Just (L NoLoc []))) | cat <- nub (concat (map cf2cat rules))] ----notPredef cat lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats] (funs,lins) = unzip (map cf2rule rules) diff --git a/src/compiler/GF/Grammar/EBNF.hs b/src/compiler/GF/Grammar/EBNF.hs index 11a2b3c4b..e5cbf6c7f 100644 --- a/src/compiler/GF/Grammar/EBNF.hs +++ b/src/compiler/GF/Grammar/EBNF.hs @@ -24,13 +24,14 @@ import GF.Grammar.Grammar import Data.Char import Data.List +import System.FilePath -- AR 18/4/2000 - 31/3/2004 -getEBNF :: String -> String -> Err SourceGrammar -getEBNF name = fmap (cf2gf name . ebnf2cf) . pEBNF +getEBNF :: FilePath -> String -> Err SourceGrammar +getEBNF fpath = fmap (cf2gf fpath . ebnf2cf) . pEBNF type EBNF = [ERule] type ERule = (ECat, ERHS) @@ -54,7 +55,7 @@ type CFJustRule = (CFCat, CFRHS) ebnf2cf :: EBNF -> [CFRule] ebnf2cf ebnf = - [L (0,0) (mkCFF i rule,rule) | (i,rule) <- zip [0..] (normEBNF ebnf)] where + [L NoLoc (mkCFF i rule,rule) | (i,rule) <- zip [0..] (normEBNF ebnf)] where mkCFF i (c, _) = ("Mk" ++ c ++ "_" ++ show i) normEBNF :: EBNF -> [CFJustRule] diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index ae29ab6d5..627355033 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -20,7 +20,7 @@ module GF.Grammar.Grammar (SourceGrammar, SourceModule, mapSourceModule, Info(..), - L(..), unLoc, + Location(..), L(..), unLoc, Type, Cat, Fun, @@ -80,7 +80,7 @@ data Info = | AbsFun (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) (Maybe Bool) -- ^ (/ABS/) type, arrity and definition of a function -- judgements in resource - | ResParam (Maybe [L Param]) (Maybe [Term]) -- ^ (/RES/) the second parameter is list of all possible values + | ResParam (Maybe (L [Param])) (Maybe [Term]) -- ^ (/RES/) the second parameter is list of all possible values | ResValue (L Type) -- ^ (/RES/) to mark parameter constructors for lookup | ResOper (Maybe (L Type)) (Maybe (L Term)) -- ^ (/RES/) @@ -94,8 +94,14 @@ data Info = | AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical deriving Show -data L a = L (Int,Int) a -- location information - deriving (Eq,Show) +data Location + = NoLoc + | Local Int Int + | External FilePath Location + deriving (Show,Eq,Ord) + +data L a = L Location a -- location information + deriving Show instance Functor L where fmap f (L loc x) = L loc (f x) diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs index 435280963..651fde4d0 100644 --- a/src/compiler/GF/Grammar/Lookup.hs +++ b/src/compiler/GF/Grammar/Lookup.hs @@ -191,7 +191,7 @@ lookupCatContext gr m c = do -- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations -- notice that it only gives the modules that are reachable and the opers that are included -allOpers :: SourceGrammar -> [((Ident,Ident),Type,(Int,Int))] +allOpers :: SourceGrammar -> [((Ident,Ident),Type,Location)] allOpers gr = [((mo,op),typ,loc) | (mo,minc) <- reachable, @@ -212,7 +212,7 @@ allOpers gr = _ -> [] --- not for dependent types -allOpersTo :: SourceGrammar -> Type -> [((Ident,Ident),Type,(Int,Int))] +allOpersTo :: SourceGrammar -> Type -> [((Ident,Ident),Type,Location)] allOpersTo gr ty = [op | op@(_,typ,_) <- allOpers gr, isProdTo ty typ] where isProdTo t typ = eqProd typ t || case typ of Prod _ _ a b -> isProdTo t b diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index 30795cecb..38b22aaa2 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -560,7 +560,7 @@ allDependencies ism b = pts i = case i of ResOper pty pt -> [pty,pt] ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts] - ResParam (Just ps) _ -> [Just (L loc t) | L loc (_,cont) <- ps, (_,_,t) <- cont] + ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont] CncCat pty _ _ -> [pty] CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type)) AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y index 23974f6b1..26b7e123b 100644 --- a/src/compiler/GF/Grammar/Parser.y +++ b/src/compiler/GF/Grammar/Parser.y @@ -5,7 +5,7 @@ module GF.Grammar.Parser , pModDef , pModHeader , pExp - , pTopDef + , pTopDef ) where import GF.Infra.Ident @@ -118,14 +118,14 @@ ModDef defs <- case buildAnyTree id jments of Ok x -> return x Bad msg -> fail msg - return (id, ModInfo mtype mstat opts extends with opens [] defs) } + return (id, ModInfo mtype mstat opts extends with opens [] "" defs) } ModHeader :: { SourceModule } ModHeader : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ; (mtype,id) = $2 ; (extends,with,opens) = $4 } - in (id, ModInfo mtype mstat noOptions extends with opens [] emptyBinTree) } + in (id, ModInfo mtype mstat noOptions extends with opens [] "" emptyBinTree) } ComplMod :: { ModuleStatus } ComplMod @@ -251,9 +251,9 @@ DataDef ParamDef :: { [(Ident,Info)] } ParamDef - : Ident '=' ListParConstr { ($1, ResParam (Just $3) Nothing) : - [(f, ResValue (L loc (mkProdSimple co (Cn $1)))) | L loc (f,co) <- $3] } - | Ident { [($1, ResParam Nothing Nothing)] } + : Posn Ident '=' ListParConstr Posn { ($2, ResParam (Just (mkL $1 $5 [param | L loc param <- $4])) Nothing) : + [(f, ResValue (L loc (mkProdSimple co (Cn $2)))) | L loc (f,co) <- $4] } + | Posn Ident Posn { [($2, ResParam Nothing Nothing)] } OperDef :: { [(Ident,Info)] } OperDef @@ -679,7 +679,7 @@ checkInfoType mt jment@(id,info) = AbsFun pty _ pde _ -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde) CncCat pty pd ppn -> ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh ppn) CncFun _ pd ppn -> ifConcrete mt (locPerh pd ++ locPerh ppn) - ResParam pparam _ -> ifResource mt (maybe [] locAll pparam) + ResParam pparam _ -> ifResource mt (locPerh pparam) ResValue ty -> ifResource mt (locL ty) ResOper pty pt -> ifOper mt pty pt ResOverload _ xs -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs]) @@ -688,8 +688,8 @@ checkInfoType mt jment@(id,info) = locAll xs = [loc | L loc x <- xs] locL (L loc x) = [loc] - illegal ((s,e):_) = failLoc (Pn s 0) "illegal definition" - illegal _ = return jment + illegal (Local s e:_) = failLoc (Pn s 0) "illegal definition" + illegal _ = return jment ifAbstract MTAbstract locs = return jment ifAbstract _ locs = illegal locs @@ -729,6 +729,6 @@ mkAlts cs = case cs of _ -> fail "no strs from pattern" mkL :: Posn -> Posn -> x -> L x -mkL (Pn l1 _) (Pn l2 _) x = L (l1,l2) x +mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) x } diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index 5fa9121fc..ce8562db7 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -17,7 +17,7 @@ module GF.Grammar.Printer , ppPatt , ppValue , ppConstrs - , ppPosition + , ppLocation , ppQIdent ) where @@ -38,7 +38,7 @@ ppGrammar :: SourceGrammar -> Doc ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr ppModule :: TermPrintQual -> SourceModule -> Doc -ppModule q (mn, ModInfo mtype mstat opts exts with opens _ jments) = +ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) = hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr where defs = Map.toList jments @@ -97,8 +97,8 @@ ppJudgement q (id, AbsFun ptype _ pexp poper) = ppJudgement q (id, ResParam pparams _) = text "param" <+> ppIdent id <+> (case pparams of - Just ps -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps)) - _ -> empty) <+> semi + Just (L _ ps) -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps)) + _ -> empty) <+> semi ppJudgement q (id, ResValue pvalue) = empty ppJudgement q (id, ResOper ptype pexp) = text "oper" <+> ppIdent id <+> @@ -269,12 +269,14 @@ ppBind (Implicit,v) = braces (ppIdent v) ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y -ppParam q (L _ (id,cxt)) = ppIdent id <+> hsep (map (ppDDecl q) cxt) +ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt) -ppPosition :: Ident -> (Int,Int) -> Doc -ppPosition m (b,e) - | b == e = text "in" <+> ppIdent m <> text ".gf, line" <+> int b - | otherwise = text "in" <+> ppIdent m <> text ".gf, lines" <+> int b <> text "-" <> int e +ppLocation :: FilePath -> Location -> Doc +ppLocation fpath NoLoc = text fpath +ppLocation fpath (External p l) = ppLocation p l +ppLocation fpath (Local b e) + | b == e = text fpath <> colon <> int b + | otherwise = text fpath <> colon <> int b <> text "-" <> int e commaPunct f ds = (hcat (punctuate comma (map f ds))) diff --git a/src/compiler/GF/Infra/Modules.hs b/src/compiler/GF/Infra/Modules.hs index a80c0060a..67e010ece 100644 --- a/src/compiler/GF/Infra/Modules.hs +++ b/src/compiler/GF/Infra/Modules.hs @@ -46,16 +46,11 @@ import GF.Data.Operations import Data.List import qualified Data.Map as Map import Text.PrettyPrint +import System.FilePath --- AR 29/4/2003 --- The same structure will be used in both source code and canonical. --- The parameters tell what kind of data is involved. -- Invariant: modules are stored in dependency order ---mGrammar = MGrammar ---newtype MGrammar a = MGrammar {modules :: [(Ident,ModInfo a)]} - data MGrammar a = MGrammar { moduleMap :: Map.Map Ident (ModInfo a), modules :: [(Ident,ModInfo a)] } deriving Show @@ -69,6 +64,7 @@ data ModInfo a = ModInfo { mwith :: Maybe (Ident,MInclude,[(Ident,Ident)]), opens :: [OpenSpec], mexdeps :: [Ident], + msrc :: FilePath, jments :: Map.Map Ident a } deriving Show @@ -109,13 +105,13 @@ updateMGrammar (MGrammar omap os) (MGrammar nmap ns) = nis = map fst ns -} updateModule :: ModInfo t -> Ident -> t -> ModInfo t -updateModule (ModInfo mt ms fs me mw ops med js) i t = ModInfo mt ms fs me mw ops med (updateTree (i,t) js) +updateModule (ModInfo mt ms fs me mw ops med src js) i t = ModInfo mt ms fs me mw ops med src (updateTree (i,t) js) replaceJudgements :: ModInfo t -> Map.Map Ident t -> ModInfo t -replaceJudgements (ModInfo mt ms fs me mw ops med _) js = ModInfo mt ms fs me mw ops med js +replaceJudgements (ModInfo mt ms fs me mw ops med src _) js = ModInfo mt ms fs me mw ops med src js addOpenQualif :: Ident -> Ident -> ModInfo t -> ModInfo t -addOpenQualif i j (ModInfo mt ms fs me mw ops med js) = ModInfo mt ms fs me mw (OQualif i j : ops) med js +addOpenQualif i j (ModInfo mt ms fs me mw ops med src js) = ModInfo mt ms fs me mw (OQualif i j : ops) med src js addFlag :: Options -> ModInfo t -> ModInfo t addFlag f mo = mo {flags = flags mo `addOptions` f} @@ -227,7 +223,7 @@ emptyMGrammar :: MGrammar a emptyMGrammar = mGrammar [] emptyModInfo :: ModInfo a -emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree +emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "" emptyBinTree -- | we store the module type with the identifier diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index 27594f57f..b238de3cb 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -74,7 +74,7 @@ errors = fail . unlines -- Types data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeRun | ModeCompiler - | ModeServer + | ModeServer | ModeTags deriving (Show,Eq,Ord) data Verbosity = Quiet | Normal | Verbose | Debug @@ -299,6 +299,7 @@ optDescr = Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).", Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).", Option [] ["server"] (NoArg (mode ModeServer)) "Run in HTTP server mode.", + Option [] ["tags"] (NoArg (mode ModeTags)) "Build TAGS file and exit.", Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).", Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.", Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .", diff --git a/src/compiler/GFTags.hs b/src/compiler/GFTags.hs new file mode 100644 index 000000000..7e56f9a4f --- /dev/null +++ b/src/compiler/GFTags.hs @@ -0,0 +1,51 @@ +module GFTags where + +import GF.Infra.Option +import GF.Infra.Modules +import GF.Infra.UseIO +import GF.Grammar +import GF.Compile + +import Data.List +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Monad +import Text.PrettyPrint + +mainTags opts files = do + gr <- batchCompile opts files + let tags = foldl getTags [] (modules gr) + ioeIO (writeFile "tags" (unlines ((Set.toList . Set.fromList) tags))) + +getTags x (m,mi) = + [showIdent i ++ "\t" ++ k ++ "\t" ++ l ++ "\t" ++ t + | (i,jment) <- Map.toList (jments mi), + (k,l,t) <- getLocations jment] ++ x + where + getLocations :: Info -> [(String,String,String)] + getLocations (AbsCat mb_ctxt) = maybe (loc "cat") mb_ctxt + getLocations (AbsFun mb_type _ mb_eqs _) = maybe (ltype "fun") mb_type ++ + maybe (list (loc "def")) mb_eqs + getLocations (ResParam mb_params _) = maybe (loc "param") mb_params + getLocations (ResValue mb_type) = ltype "param-value" mb_type + getLocations (ResOper mb_type mb_def) = maybe (ltype "oper-type") mb_type ++ + maybe (loc "oper-def") mb_def + getLocations (ResOverload _ defs) = list (\(x,y) -> ltype "overload-type" x ++ + loc "overload-def" y) defs + getLocations (CncCat mb_type mb_def mb_prn) = maybe (loc "lincat") mb_type ++ + maybe (loc "lindef") mb_def ++ + maybe (loc "printname") mb_prn + getLocations (CncFun _ mb_lin mb_prn) = maybe (loc "lin") mb_lin ++ + maybe (loc "printname") mb_prn + getLocations _ = [] + + loc kind (L loc _) = [(kind,render (ppLocation (msrc mi) loc),"")] + + ltype kind (L loc ty) = [(kind,render (ppLocation (msrc mi) loc),render (ppTerm Unqualified 0 ty))] + + maybe f (Just x) = f x + maybe f Nothing = [] + + list f xs = concatMap f xs + + render = renderStyle style{mode=OneLineMode}