diff options
Diffstat (limited to 'src/GF/Compile')
| -rw-r--r-- | src/GF/Compile/CheckGrammar.hs | 12 | ||||
| -rw-r--r-- | src/GF/Compile/GrammarToGFCC.hs | 4 | ||||
| -rw-r--r-- | src/GF/Compile/Optimize.hs | 2 | ||||
| -rw-r--r-- | src/GF/Compile/TC.hs | 2 | ||||
| -rw-r--r-- | src/GF/Compile/TypeCheck.hs | 2 |
5 files changed, 11 insertions, 11 deletions
diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 98cd17f23..67526b5b5 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/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) diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs index 18e262de7..9d0a45e41 100644 --- a/src/GF/Compile/GrammarToGFCC.hs +++ b/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 diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs index e83f0e912..f0308cb7c 100644 --- a/src/GF/Compile/Optimize.hs +++ b/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 diff --git a/src/GF/Compile/TC.hs b/src/GF/Compile/TC.hs index 8cc2ff45b..c319cbd4a 100644 --- a/src/GF/Compile/TC.hs +++ b/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") diff --git a/src/GF/Compile/TypeCheck.hs b/src/GF/Compile/TypeCheck.hs index f2f494c31..05b0b288a 100644 --- a/src/GF/Compile/TypeCheck.hs +++ b/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 |
