msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Better error message for Predef.error

Browse Source 
+ 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.
This commit is contained in:
hallgren
2013-01-28 16:12:56 +00:00
parent 3360cc904c
commit 713e883ad7
6 changed files with 62 additions and 37 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
src/compiler/GF/Compile.hs
View File

@@ -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 =

17
src/compiler/GF/Compile/Compute/ConcreteNew.hs
View File

@@ -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 $

2
src/compiler/GF/Compile/Compute/Predef.hs
View File

@@ -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

55
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -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 opts sgr cmo@(cm,cmi) = do
(seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr cenv am cm) Map.empty (jments cmi)
when (verbAtLeast opts Verbose) $ hPutStrLn stderr ""
generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule
generatePMCFG opts sgr opath cmo@(cm,cmi) = do
(seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr cenv opath am cm) Map.empty (jments cmi)
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 opts gr cenv am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
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
(seqs1,b1) = addSequencesB seqs b
b <- convert opts gr cenv (floc opath loc id) term val pargs
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]
(seqs1,b1) = addSequencesB seqs b
b <- convert opts gr cenv (floc opath loc id) term lincat [parg]
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

5
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -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)

11
src/compiler/GF/Infra/UseIO.hs
View File

@@ -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))
appIOE :: IOE a -> IO (Err a)
appIOE (IOE iea) = iea
newtype IOE a = IOE { appIOE :: IO (Err a) }
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