Better error message for Predef.error

+ Instead of "Internal error in ...", you now get a proper error message with
  a source location and a function name.
+ Also added some missing error value propagation in the partial evaluator.
+ Also some other minor cleanup and error handling fixes.

src/compiler/GF/Compile.hs

@@ -30,7 +30,7 @@ import System.IO
 import System.Directory
 import System.FilePath
 import qualified Data.Map as Map
-import qualified Data.Set as Set
+--import qualified Data.Set as Set
 import Data.List(nub)
 import Data.Maybe (isNothing)
 import qualified Data.ByteString.Char8 as BS
@@ -55,7 +55,7 @@ link opts cnc gr = do
   let isv = (verbAtLeast opts Normal)
   putPointE Normal opts "linking ... " $ do
     let abs = err (const cnc) id $ abstractOfConcrete gr cnc
-    pgf <- ioeIO (mkCanon2pgf opts gr abs)
+    pgf <- mkCanon2pgf opts gr abs
     probs <- ioeIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
     ioeIO $ when (verbAtLeast opts Normal) $ putStrFlush "OK"     
     return $ setProbabilities probs 
@@ -196,7 +196,7 @@ compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do
                      refreshModule (k,gr) mo3
       mo4 <- runPass2 id Optimize "optimizing" $ optimizeModule opts gr mo3r
       mo5 <- if isModCnc (snd mo4) && flag optPMCFG opts
-             then runPass2' "generating PMCFG" $ generatePMCFG opts gr mo4
+             then runPass2' "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4
              else runPass2' "" $ return mo4
       generateGFO k' mo5
 
@@ -215,9 +215,10 @@ compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do
     putpp s = if null s then id else putPointE Verbose opts ("  "++s++" ")
     idump pass = intermOut opts (Dump pass) . ppModule Internal
 
+    -- * Impedance matching
     runPass = runPass' fst fst snd (ioeErr . runCheck)
     runPass2 = runPass2e ioeErr
-    runPass2' = runPass2e ioeIO id Canon
+    runPass2' = runPass2e id id Canon
     runPass2e lift f = runPass' id f (const "") lift
 
     runPass' ret dump warn lift pass pp m =

src/compiler/GF/Compile/Compute/ConcreteNew.hs

@@ -1,7 +1,7 @@
 -- | Functions for computing the values of terms in the concrete syntax, in
 -- | preparation for PMCFG generation.
 module GF.Compile.Compute.ConcreteNew
-           (GlobalEnv, resourceValues, normalForm
+           (GlobalEnv, resourceValues, normalForm, ppL
            --, Value(..), Env, value2term, eval, apply
            ) where
 
@@ -148,7 +148,7 @@ value env t0 =
     T i cs  -> valueTable env i cs
     V ty ts -> do pvs <- paramValues env ty
                   ((VV ty pvs .) . sequence) # mapM (value env) ts
-    C t1 t2 -> ((vconcat.) # both id) # both (value env) (t1,t2)
+    C t1 t2 -> ((ok2p vconcat.) # both id) # both (value env) (t1,t2)
     S t1 t2 -> ((select env.) # both id) # both (value env) (t1,t2)
     P t l   -> --maybe (bug $ "project "++show l++" from "++show v) id $
                do ov <- value env t
@@ -156,7 +156,7 @@ value env t0 =
                                    in maybe (VP v l) id (proj l v)
     Alts t tts -> (\v vts -> VAlts # v <# mapM (both id) vts) # value env t <# mapM (both (value env)) tts
     Strs ts    -> ((VStrs.) # sequence) # mapM (value env) ts
-    Glue t1 t2 -> ((glue.) # both id) # both (value env) (t1,t2)
+    Glue t1 t2 -> ((ok2p glue.) # both id) # both (value env) (t1,t2)
     ELin c r -> (unlockVRec c.) # value env r
     EPatt p  -> return $ const (VPatt p) -- hmm
     t -> fail.render $ text "value"<+>ppTerm Unqualified 10 t $$ text (show t)
@@ -167,9 +167,7 @@ paramValues env ty = do let ge = global env
 
 vconcat vv@(v1,v2) =
     case vv of
-      (VError _,_) -> v1
       (VString "",_) -> v2
-      (_,VError _) -> v2
       (_,VString "") -> v1
       _ -> VC v1 v2
 
@@ -190,6 +188,10 @@ ok2 f v1@(VError {}) _ = v1
 ok2 f _ v2@(VError {}) = v2
 ok2 f v1 v2 = f v1 v2
 
+ok2p f (v1@VError {},_) = v1
+ok2p f (_,v2@VError {}) = v2
+ok2p f vv = f vv
+
 unlockVRec ::Ident -> Value -> Value
 unlockVRec c v =
     case v of
@@ -470,9 +472,10 @@ m1 @@ m2 = (m1 =<<) . m2
 
 both f (x,y) = (,) # f x <# f y
 
-ppL (L loc x) = ppLocation "" loc<>text ":"<>ppIdent x
+ppL (L loc x) msg = hang (ppLocation "" loc<>colon) 4
+                         (text "In"<+>ppIdent x<>colon<+>msg)
 
-bugloc loc s = ppbug $ hang (text "In"<+>ppL loc<>text ":") 4 (text s)
+bugloc loc s = ppbug $ ppL loc (text s)
 
 bug msg = ppbug (text msg)
 ppbug doc = error $ render $

src/compiler/GF/Compile/Compute/Predef.hs

@@ -109,7 +109,7 @@ delta f vs =
              [v1,v2] -> toValue `fmap` (f `fmap` fromValue v1 `ap` fromValue v2)
              _ -> delay
 
-    unimpl id = bug $ "unimplemented predefined function: "++showIdent id
+--  unimpl id = bug $ "unimplemented predefined function: "++showIdent id
 --  problem id vs = bug $ "unexpected arguments: Predef."++showIdent id++" "++show vs
 
     tk i s = take (max 0 (length s - i)) s :: String

src/compiler/GF/Compile/GeneratePMCFG.hs

@@ -22,8 +22,9 @@ import GF.Grammar.Lookup
 import GF.Grammar.Predef
 import GF.Data.BacktrackM
 import GF.Data.Operations
+import GF.Infra.UseIO (IOE)
 import GF.Data.Utilities (updateNthM, updateNth)
-import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues)
+import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues,ppL)
 import System.IO(hPutStr,hPutStrLn,stderr)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
@@ -38,15 +39,16 @@ import Data.Maybe
 import Data.Char (isDigit)
 import Control.Monad
 import Control.Monad.Identity
+import Control.Monad.Trans (liftIO)
 import Control.Exception
 
 ----------------------------------------------------------------------
 -- main conversion function
 
-generatePMCFG :: Options -> SourceGrammar -> SourceModule -> IO SourceModule
+generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule
-generatePMCFG opts sgr cmo@(cm,cmi) = do
+generatePMCFG opts sgr opath cmo@(cm,cmi) = do
-  (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr cenv am cm) Map.empty (jments cmi)
+  (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr cenv opath am cm) Map.empty (jments cmi)
-  when (verbAtLeast opts Verbose) $ hPutStrLn stderr ""
+  when (verbAtLeast opts Verbose) $ liftIO $ hPutStrLn stderr ""
   return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js})
   where
     cenv = resourceValues gr
@@ -65,15 +67,15 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m
                                    return (a,(k,y):kys)
 
 
-addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Ident -> Ident -> SeqSet -> Ident -> Info -> IO (SeqSet, Info)
+addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
-addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
+addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
   let pres  = protoFCat gr res val
       pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
 
       pmcfgEnv0   = emptyPMCFGEnv
 
-      b          = convert opts gr cenv (L loc id) term val pargs
+  b             <- convert opts gr cenv (floc opath loc id) term val pargs
-      (seqs1,b1) = addSequencesB seqs b
+  let (seqs1,b1) = addSequencesB seqs b
       pmcfgEnv1  = foldBM addRule
                           pmcfgEnv0
                           (goB b1 CNil [])
@@ -86,9 +88,9 @@ addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val))
                        !funs_cnt        = e-s+1
                    in (prods_cnt,funs_cnt)
 
-  when (verbAtLeast opts Verbose) $ hPutStr stderr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs)))
+  when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs)))
   seqs1 `seq` stats `seq` return ()
-  when (verbAtLeast opts Verbose) $ hPutStr stderr (" "++show stats)
+  when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr (" "++show stats)
   return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
   where
     (ctxt,res,_) = err bug typeForm (lookupFunType gr am id)
@@ -99,20 +101,20 @@ addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val))
           newArgs  = map getFIds newArgs'
       in addFunction env0 newCat fun newArgs
 
-addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L loc term)) mprn Nothing) = do
+addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L loc term)) mprn Nothing) = do
   let pres = protoFCat gr (am,id) lincat
       parg = protoFCat gr (identW,cVar) typeStr
 
       pmcfgEnv0  = emptyPMCFGEnv
 
-      b          = convert opts gr cenv (L loc id) term lincat [parg]
+  b             <- convert opts gr cenv (floc opath loc id) term lincat [parg]
-      (seqs1,b1) = addSequencesB seqs b
+  let (seqs1,b1) = addSequencesB seqs b
       pmcfgEnv1  = foldBM addRule
                           pmcfgEnv0
                           (goB b1 CNil [])
                           (pres,[parg])
       pmcfg     = getPMCFG pmcfgEnv1
-  when (verbAtLeast opts Verbose) $ hPutStr stderr ("\n+ "++showIdent id++" "++show (catFactor pres))
+  when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr ("\n+ "++showIdent id++" "++show (catFactor pres))
   seqs1 `seq` pmcfg `seq` return (seqs1,GF.Grammar.CncCat mty mdef mprn (Just pmcfg))
   where
     addRule lins (newCat', newArgs') env0 =
@@ -120,12 +122,17 @@ addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) m
           !fun     = mkArray lins
       in addFunction env0 newCat fun [[fidVar]]
 
-addPMCFG opts gr cenv am cm seqs id info = return (seqs, info)
+addPMCFG opts gr cenv opath am cm seqs id info = return (seqs, info)
+
+floc opath loc id = maybe (L loc id) (\path->L (External path loc) id) opath
 
 convert opts gr cenv loc term val pargs =
-    runCnvMonad gr conv (pargs,[])
+    case term' of
+      Error s -> fail $ render $ ppL loc (text $ "Predef.error: "++s)
+      _ -> return $ runCnvMonad gr (conv term') (pargs,[])
   where
-    conv = convertTerm opts CNil val =<< unfactor term'
+    conv t = convertTerm opts CNil val =<< unfactor t
+
     term' = if flag optNewComp opts
             then normalForm cenv loc (recordExpand val term) -- new evaluator
             else term -- old evaluator is invoked from GF.Compile.Optimize
@@ -152,7 +159,7 @@ unfactor t = CM (\gr c -> c (unfac gr t))
                                     in V ty [restore x v u' | v <- allparams ty]
         T (TTyped ty) [(PW  ,u)] -> let u' = unfac gr u
                                     in V ty [u' | _ <- allparams ty]
-        T (TTyped ty) _ -> -- converTerm doesn't handle these tables
+        T (TTyped ty) _ -> -- convertTerm doesn't handle these tables
                            ppbug $
                            sep [text "unfactor"<+>ppTerm Unqualified 10 t,
                                 text (show t)]
@@ -241,6 +248,7 @@ choices nr path = do (args,_) <- get
                                                      values          -> let path = reversePath rpath
                                                                         in CM (\gr c s -> Case nr path [(value, updateEnv path value gr c s)
                                                                                                                     | (value,index) <- values])
+    descend schema       path              rpath = bug $ "descend "++show (schema,path,rpath)
 
     updateEnv path value gr c (args,seq) = 
       case updateNthM (restrictProtoFCat path value) nr args of
@@ -271,6 +279,15 @@ data Schema b s c
   | CTbl Type [(Term, b (Schema b s c))]
   | CStr s
   | CPar c
+--deriving Show -- doesn't work
+
+instance Show s => Show (Schema b s c) where
+  showsPrec _ sch =
+      case sch of
+        CRec r   -> showString "CRec " . shows (map fst r)
+        CTbl t _ -> showString "CTbl " . showsPrec 10 t . showString " _"
+        CStr s   -> showString "CStr " . showsPrec 10 s
+        CPar c   -> showString "CPar{}"
 
 -- | Path into a term or term schema
 data Path

src/compiler/GF/Compile/GrammarToPGF.hs

@@ -22,6 +22,7 @@ import GF.Compile.GeneratePMCFG
 
 import GF.Infra.Ident
 import GF.Infra.Option
+import GF.Infra.UseIO (IOE)
 import GF.Data.Operations
 
 import Data.List
@@ -35,7 +36,7 @@ import Text.PrettyPrint
 import Control.Monad.Identity
 
 
-mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IO D.PGF
+mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IOE D.PGF
 mkCanon2pgf opts gr am = do
   (an,abs) <- mkAbstr am
   cncs     <- mapM mkConcr (allConcretes gr am)
@@ -96,7 +97,7 @@ mkCanon2pgf opts gr am = do
         -- we have to create the PMCFG code just before linking
         addMissingPMCFGs seqs []                  = return (seqs,[])
         addMissingPMCFGs seqs (((m,id), info):is) = do
-          (seqs,info) <- addPMCFG opts gr cenv am cm seqs id info
+          (seqs,info) <- addPMCFG opts gr cenv Nothing am cm seqs id info
           (seqs,is  ) <- addMissingPMCFGs seqs is
           return (seqs, ((m,id), info) : is)
 

src/compiler/GF/Infra/UseIO.hs

@@ -32,6 +32,7 @@ import System.CPUTime
 import System.Cmd
 import Text.Printf
 import Control.Monad
+import Control.Monad.Trans(MonadIO(..))
 import Control.Exception(evaluate)
 import qualified Data.ByteString.Char8 as BS
 
@@ -126,10 +127,7 @@ putStrLnFlush s = putStrLn s >> hFlush stdout
 
 -- * IO monad with error; adapted from state monad
 
-newtype IOE a = IOE (IO (Err a))
+newtype IOE a = IOE { appIOE :: IO (Err a) }
-
-appIOE :: IOE a -> IO (Err a)
-appIOE (IOE iea) = iea
 
 ioe :: IO (Err a) -> IOE a
 ioe = IOE
@@ -140,6 +138,9 @@ ioeIO io = ioe (io >>= return . return)
 ioeErr :: Err a -> IOE a
 ioeErr = ioe . return 
 
+ioeErrIn :: String -> IOE a -> IOE a
+ioeErrIn msg (IOE ioe) = IOE (fmap (errIn msg) ioe)
+
 instance Functor IOE where fmap = liftM
 
 instance  Monad IOE where
@@ -149,6 +150,8 @@ instance  Monad IOE where
                   appIOE $ err ioeBad f x         -- f :: a -> IOE a
   fail = ioeBad
 
+instance MonadIO IOE where liftIO = ioeIO
+
 ioeBad :: String -> IOE a
 ioeBad = ioe . return . Bad