refactoring in GF.Grammar.Macros

src/GF/Compile/CheckGrammar.hs

@@ -163,7 +163,7 @@ checkCompleteGrammar gr abs cnc = do
      _ -> False
    checkOne js i@(c,info) = case info of
      AbsFun (Just ty) _ _ -> do let mb_def = do
-                                      (cxt,(_,i),_) <- typeForm ty
+                                      let (cxt,(_,i),_) = typeForm ty
                                       info <- lookupIdent i js
                                       info <- case info of
                                                 (AnyInd _ m) -> do (m,info) <- lookupOrigInfo gr m i
@@ -224,7 +224,7 @@ checkResInfo gr mo mm c info = do
       --- this can only be a partial guarantee, since matching
       --- with value type is only possible if expected type is given
       checkUniq $ 
-        sort [t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1, Ok (xs,t) <- [typeFormCnc x]]
+        sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
       return (ResOverload os [(y,x) | (x,y) <- tysts'])
 
     ResParam (Just (pcs,_)) -> chIn "parameter type" $ do
@@ -255,7 +255,7 @@ checkCncInfo gr m mo (a,abs) c info = do
 
     CncFun _ (Just trm) mpr -> chIn "linearization of" $ do
       typ        <- checkErr $ lookupFunType gr a c
-      cat0       <- checkErr $ valCat typ
+      let cat0   =  valCat typ
       (cont,val) <- linTypeOfType gr m typ         -- creates arg vars
       (trm',_)   <- check trm (mkFunType (map (\(_,_,ty) -> ty) cont) val)  -- erases arg vars
       checkPrintname gr mpr
@@ -574,7 +574,7 @@ inferLType gr trm = case trm of
      _ -> False
 
    inferPatt p = case p of
-     PP q c ps | q /= cPredef -> checkErr $ lookupResType gr q c >>= valTypeCnc
+     PP q c ps | q /= cPredef -> checkErr $ liftM valTypeCnc (lookupResType gr q c)
      PAs _ p  -> inferPatt p
      PNeg p   -> inferPatt p
      PAlt p q -> checks [inferPatt p, inferPatt q]
@@ -830,7 +830,7 @@ pattContext env typ p = case p of
   PV x -> return [(Explicit,x,typ)]
   PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
     t <- checkErr $ lookupResType cnc q c
-    (cont,v) <- checkErr $ typeFormCnc t
+    let (cont,v) = typeFormCnc t
     checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p) 
               (length cont == length ps)
     checkEqLType env typ v (patt2term p)
@@ -998,7 +998,7 @@ ppType env ty =
 -- | linearization types and defaults
 linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type)
 linTypeOfType cnc m typ = do
-  (cont,cat) <- checkErr $ typeSkeleton typ
+  let (cont,cat) = typeSkeleton typ
   val  <- lookLin cat
   args <- mapM mkLinArg (zip [0..] cont)
   return (args, val)

src/GF/Compile/GrammarToGFCC.hs

@@ -126,8 +126,8 @@ b2b A.Implicit = C.Implicit
 mkType :: [Ident] -> A.Type -> C.Type
 mkType scope t =
   case GM.typeForm t of
-    Ok (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
-                              in C.DTyp hyps' (i2i cat) (map (mkExp scope') args)
+    (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
+                           in C.DTyp hyps' (i2i cat) (map (mkExp scope') args)
 
 mkExp :: [Ident] -> A.Term -> C.Expr
 mkExp scope t = case GM.termForm t of

src/GF/Compile/Optimize.hs

@@ -127,7 +127,7 @@ evalCncInfo opts gr cnc abs (c,info) = do
     return (CncCat ptyp pde' ppr')
 
   CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> --trace (prt c) $
-       eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd (cont,val,[])) $$ text "of function") $ do
+       eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do
     pde' <- case pde of
       Just de -> liftM Just $ pEval ty de
       Nothing -> return pde

src/GF/Compile/TC.hs

@@ -239,7 +239,7 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
      PString s -> (K s : ps, i, g, k)
      PInt n -> (EInt n : ps, i, g, k)
      PFloat n -> (EFloat n : ps, i, g, k)
-     PP m c xs -> (mkApp (qq (m,c)) xss : ps, j, g',k') 
+     PP m c xs -> (mkApp (Q m c) xss : ps, j, g',k') 
                     where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
      _ -> error $ render (text "undefined p2t case" <+> ppPatt Unqualified 0 p <+> text "in checkBranch")
 

src/GF/Compile/TypeCheck.hs

@@ -42,7 +42,7 @@ type2val :: Type -> Val
 type2val = VClos []
 
 cont2exp :: Context -> Exp
-cont2exp c = mkProd (c, eType, []) -- to check a context
+cont2exp c = mkProd c eType [] -- to check a context
 
 cont2val :: Context -> Val
 cont2val = type2val . cont2exp