more structured format for errors and warnings from the compiler

src/compiler/GF.hs

@@ -46,4 +46,4 @@ mainOpts opts files =
       ModeInteractive -> mainGFI opts files
       ModeRun         -> mainRunGFI opts files
       ModeServer      -> mainServerGFI opts files
-      ModeCompiler    -> dieIOE (mainGFC opts files)
+      ModeCompiler    -> mainGFC opts files

src/compiler/GF/Compile.hs

@@ -82,6 +82,13 @@ intermOut opts d doc
   | dump opts d = ioeIO (hPutStrLn stderr (render (text "\n\n--#" <+> text (show d) $$ doc)))
   | otherwise   = return ()
 
+warnOut opts warnings
+  | null warnings = return ()
+  | otherwise     = ioeIO (hPutStrLn stderr $ 
+                                     if flag optVerbosity opts == Normal
+                                       then ('\n':warnings)
+                                       else warnings)
+
 -- | the environment
 type CompileEnv = (Int,SourceGrammar,ModEnv)
 
@@ -173,8 +180,7 @@ compileOne opts env@(_,srcgr,_) file = do
 compileSourceModule :: Options -> CompileEnv -> Maybe FilePath -> SourceModule -> IOE CompileEnv
 compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do
 
-  let puts  = putPointE Quiet opts
+  let putpp = putPointE Verbose opts
-      putpp = putPointE Verbose opts
       
   mo1   <- ioeErr $ rebuildModule gr mo
   intermOut opts DumpRebuild (ppModule Qualified mo1)
@@ -198,11 +204,11 @@ compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do
       let mos = modules gr
 
       (mo2,warnings) <- putpp "  renaming " $ ioeErr $ runCheck (renameModule mos mo1b)
-      if null warnings then return () else puts warnings $ return ()
+      warnOut opts warnings
       intermOut opts DumpRename (ppModule Qualified mo2)
 
       (mo3,warnings) <- putpp "  type checking" $ ioeErr $ runCheck (checkModule mos mo2)
-      if null warnings then return () else puts warnings $ return ()
+      warnOut opts warnings
       intermOut opts DumpTypeCheck (ppModule Qualified mo3)
 
       if not (flag optTagsOnly opts)

src/compiler/GF/Compile/CheckGrammar.hs

@@ -43,24 +43,24 @@ import Text.PrettyPrint
 
 -- | checking is performed in the dependency order of modules
 checkModule :: [SourceModule] -> SourceModule -> Check SourceModule
-checkModule ms m@(name,mo) = checkIn (text "checking module" <+> ppIdent name) $ do
+checkModule mos mo@(m,mi) = do
-  checkRestrictedInheritance ms m
+  checkRestrictedInheritance mos mo
-  m <- case mtype mo of
+  mo <- case mtype mi of
-         MTConcrete a -> do let gr = mGrammar (m:ms)
+          MTConcrete a -> do let gr = mGrammar (mo:mos)
-                            abs <- checkErr $ lookupModule gr a
+                             abs <- checkErr $ lookupModule gr a
-                            checkCompleteGrammar gr (a,abs) m
+                             checkCompleteGrammar gr (a,abs) mo
-         _            -> return m
+          _            -> return mo
-  infos <- checkErr $ topoSortJments m
+  infos <- checkErr $ topoSortJments mo
-  foldM updateCheckInfo m infos
+  foldM updateCheckInfo mo infos
   where
-    updateCheckInfo (name,mo) (i,info) = do
+    updateCheckInfo mo@(m,mi) (i,info) = do
-      info <- checkInfo ms (name,mo) i info
+      info <- checkInfo mos mo i info
-      return (name,mo{jments=updateTree (i,info) (jments mo)})
+      return (m,mi{jments=updateTree (i,info) (jments mi)})
 
 -- check if restricted inheritance modules are still coherent
 -- i.e. that the defs of remaining names don't depend on omitted names
 checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check ()
-checkRestrictedInheritance mos (name,mo) = do
+checkRestrictedInheritance mos (name,mo) = checkIn (ppLocation (msrc mo) NoLoc <> colon) $ do
   let irs = [ii | ii@(_,mi) <- mextend mo, mi /= MIAll]  -- names with restr. inh.
   let mrs = [((i,m),mi) | (i,m) <- mos, Just mi <- [lookup i irs]]
                              -- the restr. modules themself, with restr. infos
@@ -79,7 +79,7 @@ checkRestrictedInheritance mos (name,mo) = do
    allDeps = concatMap (allDependencies (const True) . jments . snd) mos
 
 checkCompleteGrammar :: SourceGrammar -> SourceModule -> SourceModule -> Check SourceModule
-checkCompleteGrammar gr (am,abs) (cm,cnc) = do
+checkCompleteGrammar gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc) NoLoc <> colon) $ do
   let jsa = jments abs
   let jsc = jments cnc
 
@@ -112,25 +112,23 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
                                     Ok (CncFun ty Nothing    mn mf) ->
                                       case mb_def of
                                         Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) mn mf) js
-                                        Bad _  -> do checkWarn $ text "no linearization of" <+> ppIdent c
+                                        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 NoLoc def)) Nothing Nothing) js
-                                        Bad _  -> do checkWarn $ text "no linearization of" <+> ppIdent c
+                                        Bad _  -> do checkWarn (text "no linearization of" <+> ppIdent c)
                                                      return js
        AbsCat (Just _) -> case lookupIdent c js of
          Ok (AnyInd _ _) -> return js
          Ok (CncCat (Just _) _ _ _) -> return js
-         Ok (CncCat _ mt mp mpmcfg) -> do
+         Ok (CncCat Nothing mt mp mpmcfg) -> do
-           checkWarn $ 
+           checkWarn (text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}")
-             text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
            return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) mt mp mpmcfg) js
          _ -> do
-           checkWarn $ 
+           checkWarn (text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}")
-             text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
            return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing) js
        _ -> return js
      
@@ -141,11 +139,11 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
                                         do (cont,val) <- linTypeOfType gr cm ty
                                            let linty = (snd (valCat ty),cont,val)
                                            return $ updateTree (c,CncFun (Just linty) d mn mf) js
-                             _       -> do checkWarn $ text "function" <+> ppIdent c <+> text "is not in abstract"
+                             _       -> do checkWarn (text "function" <+> ppIdent c <+> text "is not in abstract")
                                            return js
        CncCat _ _ _ _   -> case lookupOrigInfo gr (am,c) of
                              Ok _ -> return $ updateTree i js
-                             _    -> do checkWarn $ text "category" <+> ppIdent c <+> text "is not in abstract"
+                             _    -> do checkWarn (text "category" <+> ppIdent c <+> text "is not in abstract")
                                         return js
        _                -> return $ updateTree i js
 
@@ -154,7 +152,8 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
 -- A May-value has always been checked in its origin module.
 checkInfo :: [SourceModule] -> SourceModule -> Ident -> Info -> Check Info
 checkInfo ms (m,mo) c info = do
-  checkReservedId c
+  checkIn (ppLocation (msrc mo) NoLoc <> colon) $
+    checkReservedId c
   case info of
     AbsCat (Just (L loc cont)) -> 
       mkCheck loc "the category" $ 
@@ -242,7 +241,8 @@ checkInfo ms (m,mo) c info = do
     _ ->  return info
  where
    gr = mGrammar ((m,mo) : ms)
-   chIn loc cat = checkIn (ppLocation (msrc mo) loc <> colon $$ text "Happened in" <+> text cat <+> ppIdent c)
+   chIn loc cat = checkIn (ppLocation (msrc mo) loc <> colon $$ 
+                           nest 2 (text "Happened in" <+> text cat <+> ppIdent c))
 
    mkPar (f,co) = do
        vs <- checkErr $ liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
@@ -257,7 +257,9 @@ checkInfo ms (m,mo) c info = do
 
    mkCheck loc cat ss = case ss of
      [] -> return info
-     _  -> checkError (ppLocation (msrc mo) loc <> colon $$ text "Happened in" <+> text cat <+> ppIdent c $$ nest 3 (vcat ss))
+     _  -> checkError (ppLocation (msrc mo) loc <> colon $$ 
+                       nest 2 (text "Happened in" <+> text cat <+> ppIdent c $$ 
+                               nest 2 (vcat ss)))
 
    compAbsTyp g t = case t of
      Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g

src/compiler/GF/Compile/GetGrammar.hs

@@ -38,7 +38,7 @@ getSourceModule opts file0 = ioe $
        case runP pModDef content of
          Left (Pn l c,msg) -> do file <- writeTemp tmp
                                  let location = file++":"++show l++":"++show c
-                                 return (Bad (location++": "++msg))
+                                 return (Bad (location++":\n   "++msg))
          Right (i,mi)      -> do removeTemp tmp
                                  return (Ok (i,mi{mflags=mflags mi `addOptions` opts, msrc=file0}))
   `catch` (return . Bad . show)

src/compiler/GF/Compile/Rename.hs

@@ -24,7 +24,6 @@
 
 module GF.Compile.Rename (
 	       renameSourceTerm,
-	       renameSourceJudgement,
 	       renameModule
 	      ) where
 
@@ -47,20 +46,12 @@ import Text.PrettyPrint
 renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
 renameSourceTerm g m t = do
   mi     <- checkErr $ lookupModule g m
-  status <- buildStatus g m mi
+  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
-  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 mo@(m,mi) = checkIn (text "renaming module" <+> ppIdent m) $ do
+renameModule ms mo@(m,mi) = do
-  status <- buildStatus (mGrammar ms) m mi
+  status <- buildStatus (mGrammar ms) mo
   js     <- checkMap (renameInfo status mo) (jments mi)
   return (m, mi{jments = js})
 
@@ -71,42 +62,45 @@ type StatusTree = BinTree Ident StatusInfo
 type StatusInfo = Ident -> Term
 
 renameIdentTerm :: Status -> Term -> Check Term
-renameIdentTerm env@(act,imps) t = 
+renameIdentTerm env@(act,imps) t0 = 
- checkIn (text "atomic term" <+> ppTerm Qualified 0 t $$ text "given" <+> hsep (punctuate comma (map (ppIdent . fst) qualifs))) $
+  case t0 of
-   case t of
+    Vr c -> ident predefAbs c
-  Vr c -> ident predefAbs c
+    Cn c -> ident (\_ s -> checkError s) c
-  Cn c -> ident (\_ s -> checkError s) c
+    Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
-  Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t
+    Q (m',c) -> do
-  Q (m',c) -> do
+      m <- checkErr (lookupErr m' qualifs)
-    m <- checkErr (lookupErr m' qualifs)
+      f <- lookupTree showIdent c m
-    f <- lookupTree showIdent c m
+      return $ f c
-    return $ f c
+    QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
-  QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t
+    QC (m',c) -> do
-  QC (m',c) -> do
+      m <- checkErr (lookupErr m' qualifs)
-    m <- checkErr (lookupErr m' qualifs)
+      f <- lookupTree showIdent c m
-    f <- lookupTree showIdent c m
+      return $ f c
-    return $ f c
+    _ -> return t0
-  _ -> return t
+  where
- where
+    opens   = [st  | (OSimple _,st) <- imps]
-   opens  = [st  | (OSimple _,st) <- imps]
+    qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ 
-   qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ 
+              [(m, st) | (OQualif _ m, st) <- imps] ++ 
-             [(m, st) | (OQualif _ m, st) <- imps] ++ 
+              [(m, st) | (OSimple m, st) <- imps] -- qualif is always possible
-             [(m, st) | (OSimple m, st) <- imps] -- qualif is always possible
 
-   -- this facility is mainly for BWC with GF1: you need not import PredefAbs
+    -- this facility is mainly for BWC with GF1: you need not import PredefAbs
-   predefAbs c s
+    predefAbs c s
-     | isPredefCat c = return $ Q (cPredefAbs,c)
+      | isPredefCat c = return (Q (cPredefAbs,c))
-     | otherwise     = checkError s
+      | otherwise     = checkError s
 
-   ident alt c = case lookupTree showIdent c act of
+    ident alt c = 
-      Ok f -> return $ f c
+      case lookupTree showIdent c act of
-      _ -> case lookupTreeManyAll showIdent opens c of
+        Ok f -> return (f c)
-        [f] -> return $ f c
+        _    -> case lookupTreeManyAll showIdent opens c of
-        []  -> alt c (text "constant not found:" <+> ppIdent c)
+                  [f]  -> return (f c)
-        fs -> case nub [f c | f <- fs]  of
+                  []   -> alt c (text "constant not found:" <+> ppIdent c $$
-          [tr] -> return tr
+                                 text "given" <+> fsep (punctuate comma (map (ppIdent . fst) qualifs)))
-          ts@(t:_) -> do checkWarn (text "conflict" <+> hsep (punctuate comma (map (ppTerm Qualified 0) ts)))
+                  fs   -> case nub [f c | f <- fs]  of
-                         return t
+                            [tr]     -> return tr
+                            ts@(t:_) -> do checkWarn (text "atomic term" <+> ppTerm Qualified 0 t0 $$
+                                                      text "conflict" <+> hsep (punctuate comma (map (ppTerm Qualified 0) ts)) $$
+                                                      text "given" <+> fsep (punctuate comma (map (ppIdent . fst) qualifs)))
+                                           return t
             -- a warning will be generated in CheckGrammar, and the head returned
             -- in next V: 
             -- Bad $ "conflicting imports:" +++ unwords (map prt ts) 
@@ -125,15 +119,15 @@ tree2status o = case o of
   OSimple i   -> mapTree (info2status (Just i))
   OQualif i j -> mapTree (info2status (Just j))
 
-buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Check Status
+buildStatus :: SourceGrammar -> SourceModule -> Check Status
-buildStatus gr c mo = let mo' = self2status c mo in do
+buildStatus gr mo@(m,mi) = checkIn (ppLocation (msrc mi) NoLoc <> colon) $ do
-    let gr1 = prependModule gr (c,mo)
+  let gr1 = prependModule gr mo
-        ops = [OSimple e | e <- allExtends gr1 c] ++ mopens mo
+      ops = [OSimple e | e <- allExtends gr1 m] ++ mopens mi
-    mods <- checkErr $ mapM (lookupModule gr1 . openedModule) ops
+  mods <- checkErr $ mapM (lookupModule gr1 . openedModule) ops
-    let sts = map modInfo2status $ zip ops mods    
+  let sts = map modInfo2status $ zip ops mods    
-    return $ if isModCnc mo
+  return (if isModCnc mi
-      then (emptyBinTree, reverse sts) -- the module itself does not define any names
+            then (emptyBinTree,    reverse sts)  -- the module itself does not define any names
-      else (mo',reverse sts) -- so the empty ident is not needed
+            else (self2status m mi,reverse sts)) -- so the empty ident is not needed
 
 modInfo2status :: (OpenSpec,SourceModInfo) -> (OpenSpec, StatusTree)
 modInfo2status (o,mo) = (o,tree2status o (jments mo))
@@ -171,9 +165,9 @@ renameInfo status (m,mi) i info =
         x <- ren x
         return (L loc x)
 
-    renPair ren (L locx x, L locy y) = do x <- ren x
+    renPair ren (x, y) = do x <- renLoc ren x
-                                          y <- ren y
+                            y <- renLoc ren y
-                                          return (L locx x, L locy y)
+                            return (x, y)
 
     renEquation :: Status -> Equation -> Check Equation
     renEquation b (ps,t) = do

src/compiler/GF/Grammar/Parser.y

@@ -603,7 +603,7 @@ Posn
 {
 
 happyError :: P a
-happyError = fail "parse error"
+happyError = fail "syntax error"
 
 mkListId,mkConsId,mkBaseId  :: Ident -> Ident
 mkListId = prefixId (BS.pack "List")

src/compiler/GF/Infra/UseIO.hs

@@ -158,9 +158,6 @@ foldIOE f s xs = case xs of
       Ok v  -> foldIOE f v xx
       Bad m -> return $ (s, Just m)
 
-dieIOE :: IOE a -> IO a
-dieIOE x = appIOE x >>= err die return
-
 die :: String -> IO a
 die s = do hPutStrLn stderr s
            exitFailure

src/compiler/GFC.hs

@@ -24,15 +24,21 @@ import System.IO
 import Control.Exception
 
 
-mainGFC :: Options -> [FilePath] -> IOE ()
+mainGFC :: Options -> [FilePath] -> IO ()
-mainGFC opts fs = 
+mainGFC opts fs = do
-    case () of
+  r <- appIOE (case () of
-      _ | null fs -> fail $ "No input files."
+                 _ | null fs -> fail $ "No input files."
-      _ | all (extensionIs ".cf")  fs -> compileCFFiles opts fs
+                 _ | all (extensionIs ".cf")  fs -> compileCFFiles opts fs
-      _ | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f)  fs -> compileSourceFiles opts fs
+                 _ | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f)  fs -> compileSourceFiles opts fs
-      _ | all (extensionIs ".pgf") fs -> unionPGFFiles opts fs
+                 _ | all (extensionIs ".pgf") fs -> unionPGFFiles opts fs
-      _ -> fail $ "Don't know what to do with these input files: " ++ unwords fs
+                 _ -> fail $ "Don't know what to do with these input files: " ++ unwords fs)
- where extensionIs ext = (== ext) .  takeExtension
+  case r of
+    Ok x    -> return x
+    Bad msg -> die $ if flag optVerbosity opts == Normal
+                       then ('\n':msg)
+                       else msg
+ where
+   extensionIs ext = (== ext) .  takeExtension
 
 compileSourceFiles :: Options -> [FilePath] -> IOE ()
 compileSourceFiles opts fs =