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

GeneratePMCFG: prefix messages about "impossible" errors with 'Internal error:'

Browse Source 
Just to make them easier to spot when wading through thousands of lines of
warnings...
This commit is contained in:
hallgren
2012-10-24 17:08:52 +00:00
parent 61647b1dac
commit 6fcd435cd9
1 changed files with 17 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -90,7 +90,7 @@ addPMCFG opts gr am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin
when (verbAtLeast opts Verbose) $ hPutStr stderr (" "++show stats) when (verbAtLeast opts Verbose) $ hPutStr stderr (" "++show stats)
return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg)) return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
where where
(ctxt,res,_) = err error typeForm (lookupFunType gr am id) (ctxt,res,_) = err bug typeForm (lookupFunType gr am id)
addRule lins (newCat', newArgs') env0 = addRule lins (newCat', newArgs') env0 =
let [newCat] = getFIds newCat' let [newCat] = getFIds newCat'
@@ -126,7 +126,7 @@ unfactor t = CM (\gr c -> c (unfac gr t))
where where
unfac gr t = unfac gr t =
case t of case t of
T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac gr u) | v <- err error id (allParamValues gr ty)] T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac gr u) | v <- err bug id (allParamValues gr ty)]
_ -> composSafeOp (unfac gr) t _ -> composSafeOp (unfac gr) t
where where
restore x u t = case t of restore x u t = case t of
@@ -214,12 +214,12 @@ choices nr path = do (args,_) <- get
updateEnv path value gr c (args,seq) = updateEnv path value gr c (args,seq) =
case updateNthM (restrictProtoFCat path value) nr args of case updateNthM (restrictProtoFCat path value) nr args of
Just args -> c value (args,seq) Just args -> c value (args,seq)
Nothing -> error "conflict in updateEnv" Nothing -> bug "conflict in updateEnv"
-- | the argument should be a parameter type and then -- | the argument should be a parameter type and then
-- the function returns all possible values. -- the function returns all possible values.
getAllParamValues :: Type -> CnvMonad [Term] getAllParamValues :: Type -> CnvMonad [Term]
getAllParamValues ty = CM (\gr c -> c (err error id (allParamValues gr ty))) getAllParamValues ty = CM (\gr c -> c (err bug id (allParamValues gr ty)))
mkRecord :: [(Label,CnvMonad (Schema Branch s c))] -> CnvMonad (Schema Branch s c) mkRecord :: [(Label,CnvMonad (Schema Branch s c))] -> CnvMonad (Schema Branch s c)
mkRecord xs = CM (\gr c -> foldl (\c (lbl,CM m) bs s -> c ((lbl,m gr (\v s -> Return v) s) : bs) s) (c . CRec) xs []) mkRecord xs = CM (\gr c -> foldl (\c (lbl,CM m) bs s -> c ((lbl,m gr (\v s -> Return v) s) : bs) s) (c . CRec) xs [])
@@ -281,14 +281,14 @@ computeCatRange gr lincat = compute (0,1) lincat
_ -> let (st',t') = compute st t _ -> let (st',t') = compute st t
in (st',(lbl,Identity t'))) st rs in (st',(lbl,Identity t'))) st rs
in (st',CRec rs') in (st',CRec rs')
compute st (Table pt vt) = let vs = err error id (allParamValues gr pt) compute st (Table pt vt) = let vs = err bug id (allParamValues gr pt)
(st',cs') = List.mapAccumL (\st v -> let (st',vt') = compute st vt (st',cs') = List.mapAccumL (\st v -> let (st',vt') = compute st vt
in (st',(v,Identity vt'))) st vs in (st',(v,Identity vt'))) st vs
in (st',CTbl pt cs') in (st',CTbl pt cs')
compute st (Sort s) compute st (Sort s)
| s == cStr = let (index,m) = st | s == cStr = let (index,m) = st
in ((index+1,m),CStr index) in ((index+1,m),CStr index)
compute st t = let vs = err error id (allParamValues gr t) compute st t = let vs = err bug id (allParamValues gr t)
(index,m) = st (index,m) = st
in ((index,m*length vs),CPar (m,zip vs [0..])) in ((index,m*length vs),CPar (m,zip vs [0..]))
@@ -331,7 +331,7 @@ convertTerm opts sel ctype (Alts s alts)
strings (Strs ss) = concatMap strings ss strings (Strs ss) = concatMap strings ss
convertTerm opts CNil ctype t = do v <- evalTerm CNil t convertTerm opts CNil ctype t = do v <- evalTerm CNil t
return (CPar v) return (CPar v)
convertTerm _ _ _ t = error (render (text "convertTerm" <+> parens (ppTerm Unqualified 0 t))) convertTerm _ _ _ t = ppbug (text "convertTerm" <+> parens (ppTerm Unqualified 0 t))
convertArg :: Options -> Term -> Int -> Path -> CnvMonad (Value [Symbol]) convertArg :: Options -> Term -> Int -> Path -> CnvMonad (Value [Symbol])
convertArg opts (RecType rs) nr path = convertArg opts (RecType rs) nr path =
@@ -361,7 +361,7 @@ convertRec opts CNil (RecType rs) record =
mkRecord (map (\(lbl,ctype) -> (lbl,convertTerm opts CNil ctype (projectRec lbl record))) rs) mkRecord (map (\(lbl,ctype) -> (lbl,convertTerm opts CNil ctype (projectRec lbl record))) rs)
convertRec opts (CProj lbl path) ctype record = convertRec opts (CProj lbl path) ctype record =
convertTerm opts path ctype (projectRec lbl record) convertTerm opts path ctype (projectRec lbl record)
convertRec opts _ ctype _ = error ("convertRec: "++show ctype) convertRec opts _ ctype _ = bug ("convertRec: "++show ctype)
convertTbl opts CNil (Table _ vt) pt ts = do convertTbl opts CNil (Table _ vt) pt ts = do
vs <- getAllParamValues pt vs <- getAllParamValues pt
@@ -370,9 +370,9 @@ convertTbl opts (CSel v sub_sel) ctype pt ts = do
vs <- getAllParamValues pt vs <- getAllParamValues pt
case lookup v (zip vs ts) of case lookup v (zip vs ts) of
Just t -> convertTerm opts sub_sel ctype t Just t -> convertTerm opts sub_sel ctype t
Nothing -> error (render (text "convertTbl:" <+> (text "missing value" <+> ppTerm Unqualified 0 v $$ Nothing -> ppbug (text "convertTbl:" <+> (text "missing value" <+> ppTerm Unqualified 0 v $$
text "among" <+> vcat (map (ppTerm Unqualified 0) vs)))) text "among" <+> vcat (map (ppTerm Unqualified 0) vs)))
convertTbl opts _ ctype _ _ = error ("convertTbl: "++show ctype) convertTbl opts _ ctype _ _ = bug ("convertTbl: "++show ctype)
goB :: Branch (Value SeqId) -> Path -> [SeqId] -> BacktrackM Env [SeqId] goB :: Branch (Value SeqId) -> Path -> [SeqId] -> BacktrackM Env [SeqId]
@@ -460,14 +460,14 @@ evalTerm path (V pt ts) = case path of
(CSel trm path) -> do vs <- getAllParamValues pt (CSel trm path) -> do vs <- getAllParamValues pt
case lookup trm (zip vs ts) of case lookup trm (zip vs ts) of
Just t -> evalTerm path t Just t -> evalTerm path t
Nothing -> error "evalTerm: missing value" Nothing -> bug "evalTerm: missing value"
CNil -> do ts <- mapM (evalTerm path) ts CNil -> do ts <- mapM (evalTerm path) ts
return (V pt ts) return (V pt ts)
evalTerm path (S term sel) = do v <- evalTerm CNil sel evalTerm path (S term sel) = do v <- evalTerm CNil sel
evalTerm (CSel v path) term evalTerm (CSel v path) term
evalTerm path (FV terms) = variants terms >>= evalTerm path evalTerm path (FV terms) = variants terms >>= evalTerm path
evalTerm path (EInt n) = return (EInt n) evalTerm path (EInt n) = return (EInt n)
evalTerm path t = error (render (text "evalTerm" <+> parens (ppTerm Unqualified 0 t))) evalTerm path t = ppbug (text "evalTerm" <+> parens (ppTerm Unqualified 0 t))
getVarIndex (IA _ i) = i getVarIndex (IA _ i) = i
getVarIndex (IAV _ _ i) = i getVarIndex (IAV _ _ i) = i
@@ -532,7 +532,7 @@ restrictProtoFCat path v (PFCat cat f schema) = do
addConstraint CNil v (CPar (m,vs)) = case lookup v vs of addConstraint CNil v (CPar (m,vs)) = case lookup v vs of
Just index -> return (CPar (m,[(v,index)])) Just index -> return (CPar (m,[(v,index)]))
Nothing -> mzero Nothing -> mzero
addConstraint CNil v (CStr _) = error "restrictProtoFCat: string path" addConstraint CNil v (CStr _) = bug "restrictProtoFCat: string path"
update k0 f [] = return [] update k0 f [] = return []
update k0 f (x@(k,Identity v):xs) update k0 f (x@(k,Identity v):xs)
@@ -543,3 +543,6 @@ restrictProtoFCat path v (PFCat cat f schema) = do
mkArray lst = listArray (0,length lst-1) lst mkArray lst = listArray (0,length lst-1) lst
mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
bug msg = ppbug (text msg)
ppbug doc = error $ render $ text "Internal error:" <+> doc