GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

Some code verbosity reduction

Browse Source
This commit is contained in:
hallgren
2013-09-10 14:19:11 +00:00
parent aa9280b287
commit 8a3b97e6a5
1 changed files with 23 additions and 20 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -168,9 +168,9 @@ unfactor t = CM (\gr c -> c (unfac gr t))
in V ty [u' | _ <- allparams ty]
T (TTyped ty) _ -> -- convertTerm doesn't handle these tables
ppbug $
sep [text "unfactor"<+>ppTerm Unqualified 10 t,
sep [text "unfactor"<+>ppU 10 t,
text (show t){-,
fsep (map (ppTerm Unqualified 10) (allparams ty))-}]
fsep (map (ppU 10) (allparams ty))-}]
_ -> composSafeOp (unfac gr) t
where
allparams ty = err bug id (allParamValues gr ty)
@@ -348,8 +348,8 @@ computeCatRange gr lincat = compute (0,1) lincat
(index,m) = st
in ((index,m*length vs),CPar (m,zip vs [0..]))
ppPath (CProj lbl path) = ppLabel lbl <+> ppPath path
ppPath (CSel trm path) = ppTerm Unqualified 5 trm <+> ppPath path
ppPath (CProj lbl path) = ppLabel lbl <+> ppPath path
ppPath (CSel trm path) = ppU 5 trm <+> ppPath path
ppPath CNil = empty
reversePath path = rev CNil path
@@ -412,7 +412,7 @@ convertTerm opts sel@(CProj l _) ctype (ExtR t1@(R rs1) t2)
convertTerm opts CNil ctype t = do v <- evalTerm CNil t
return (CPar v)
convertTerm _ sel _ t = ppbug (text "convertTerm" <+> sep [parens (text (show sel)),ppTerm Unqualified 10 t])
convertTerm _ sel _ t = ppbug (text "convertTerm" <+> sep [parens (text (show sel)),ppU 10 t])
convertArg :: Options -> Term -> Int -> Path -> CnvMonad (Value [Symbol])
convertArg opts (RecType rs) nr path =
@@ -452,8 +452,8 @@ convertTbl opts (CSel v sub_sel) ctype pt ts = do
vs <- getAllParamValues pt
case lookup v (zip vs ts) of
Just t -> convertTerm opts sub_sel ctype t
Nothing -> ppbug (text "convertTbl:" <+> (text "missing value" <+> ppTerm Unqualified 0 v $$
text "among" <+> vcat (map (ppTerm Unqualified 0) vs)))
Nothing -> ppbug (text "convertTbl:" <+> (text "missing value" <+> ppU 0 v $$
text "among" <+> vcat (map (ppU 0) vs)))
convertTbl opts _ ctype _ _ = bug ("convertTbl: "++show ctype)
@@ -532,24 +532,25 @@ evalTerm CNil (App x y) = do x <- evalTerm CNil x
y <- evalTerm CNil y
return (App x y)
evalTerm path (Vr x) = choices (getVarIndex x) path
evalTerm path (R rs) = case path of
(CProj lbl path) -> evalTerm path (projectRec lbl rs)
CNil -> do rs <- mapM (\(lbl,(_,t)) -> do t <- evalTerm path t
return (assign lbl t)) rs
return (R rs)
evalTerm path (R rs) =
case path of
CProj lbl path -> evalTerm path (projectRec lbl rs)
CNil -> R `fmap` mapM (\(lbl,(_,t)) -> assign lbl `fmap` evalTerm path t) rs
evalTerm path (P term lbl) = evalTerm (CProj lbl path) term
evalTerm path (V pt ts) = case path of
(CSel trm path) -> do vs <- getAllParamValues pt
case lookup trm (zip vs ts) of
Just t -> evalTerm path t
Nothing -> ppbug $ text "evalTerm: missing value:"<+>ppTerm Unqualified 0 trm $$ text "among:"<+>fsep (map (ppTerm Unqualified 10) vs)
CNil -> do ts <- mapM (evalTerm path) ts
return (V pt ts)
evalTerm path (V pt ts) =
case path of
CNil -> V pt `fmap` mapM (evalTerm path) ts
CSel trm path ->
do vs <- getAllParamValues pt
case lookup trm (zip vs ts) of
Just t -> evalTerm path t
Nothing -> ppbug $ text "evalTerm: missing value:"<+>ppU 0 trm
$$ text "among:" <+>fsep (map (ppU 10) vs)
evalTerm path (S term sel) = do v <- evalTerm CNil sel
evalTerm (CSel v path) term
evalTerm path (FV terms) = variants terms >>= evalTerm path
evalTerm path (EInt n) = return (EInt n)
evalTerm path t = ppbug (text "evalTerm" <+> parens (ppTerm Unqualified 0 t))
evalTerm path t = ppbug (text "evalTerm" <+> parens (ppU 0 t))
--evalTerm path t = ppbug (text "evalTerm" <+> sep [parens (text (show path)),parens (text (show t))])
getVarIndex (IA _ i) = i
@@ -630,3 +631,5 @@ mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
bug msg = ppbug (text msg)
ppbug = error . render . hang (text "Internal error in GeneratePMCFG:") 4
ppU = ppTerm Unqualified