packages feed

curry-frontend 1.0.2 → 1.0.3

raw patch · 9 files changed

+69/−46 lines, 9 files

Files

CHANGELOG.md view
@@ -1,6 +1,11 @@ Change log for curry-frontend ============================= +Version 1.0.3+=============++  * Fixed bug in type checking of typeclasses+ Version 1.0.2 =============
curry-frontend.cabal view
@@ -1,5 +1,5 @@ Name:          curry-frontend-Version:       1.0.2+Version:       1.0.3 Cabal-Version: >= 1.10 Synopsis:      Compile the functional logic language Curry to several                intermediate formats
src/Checks/SyntaxCheck.hs view
@@ -837,7 +837,8 @@   funcPattern r qop = do     checkFuncPatsExtension (spanInfo2Pos p)     checkFuncPatCall r qop-    ts'@[t1',t2'] <- mapM (checkPattern p) [t1,t2]+    ts' <- mapM (checkPattern p) [t1,t2]+    let [t1',t2'] = ts'     mapM_ (checkFPTerm p) ts'     return $ InfixFuncPattern spi () t1' qop t2'
src/Checks/TypeCheck.hs view
@@ -552,7 +552,8 @@     (ps, tys, lhs') <- tcLhs p lhs     (ps', ty, rhs') <- tcRhs rhs     return (ps, tys, lhs', ps', ty, rhs')-  ps'' <- reducePredSet p "equation" (ppEquation (Equation p lhs' rhs')) (ps `Set.union` ps')+  ps'' <- reducePredSet p "equation" (ppEquation (Equation p lhs' rhs'))+                        (ps `Set.union` ps')   checkSkolems p "Equation" ppEquation fs ps'' (foldr TypeArrow ty tys)     (Equation p lhs' rhs') @@ -567,7 +568,8 @@   ty <- freshTypeVar   return (v, 0, monoType ty) -unifyDecl :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> PredSet -> Type+unifyDecl :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> PredSet+          -> Type           -> TCM PredSet unifyDecl p what doc psLhs tyLhs psRhs tyRhs = do   ps <- unify p what doc psLhs tyLhs psRhs tyRhs@@ -590,8 +592,8 @@   _ -> return ps defaultPDecl _ _ _ _ = internalError "TypeCheck.defaultPDecl" -applyDefaultsDecl :: HasPosition p => p -> String -> Doc -> Set.Set Int -> PredSet -> Type-                  -> TCM PredSet+applyDefaultsDecl :: HasPosition p => p -> String -> Doc -> Set.Set Int+                  -> PredSet -> Type -> TCM PredSet applyDefaultsDecl p what doc fvs ps ty = do   theta <- getTypeSubst   let ty' = subst theta ty@@ -630,7 +632,8 @@ -- because the context of a function's type signature is ignored in the -- function 'tcFunctionPDecl' above. -tcCheckPDecl :: PredSet -> QualTypeExpr -> PDecl a -> TCM (PredSet, PDecl PredType)+tcCheckPDecl :: PredSet -> QualTypeExpr -> PDecl a+             -> TCM (PredSet, PDecl PredType) tcCheckPDecl ps qty pd = do   (ps', (ty, pd')) <- tcPDecl ps pd   fvs <- computeFvEnv@@ -661,7 +664,8 @@ checkTypeSig (PredType sigPs sigTy) (ForAll _ (PredType ps ty)) = do   clsEnv <- getClassEnv   return $-    ty `eqTypes` sigTy && all (`Set.member` maxPredSet clsEnv sigPs) (Set.toList ps)+    ty `eqTypes` sigTy &&+    all (`Set.member` maxPredSet clsEnv sigPs) (Set.toList ps)  -- The function 'equTypes' computes whether two types are equal modulo -- renaming of type variables.@@ -864,9 +868,8 @@   where (vpds, opds) = partition (isValueDecl . snd) $ toPDecls ds tcTopPDecl (i, InstanceDecl p cx qcls ty ds) = do   tcEnv <- getTyConsEnv-  let ocls = origName $ head $ qualLookupTypeInfo qcls tcEnv   pty <- expandPoly $ QualTypeExpr NoSpanInfo cx ty-  vpds' <- mapM (tcInstanceMethodPDecl ocls pty) vpds+  vpds' <- mapM (tcInstanceMethodPDecl qcls pty) vpds   return (i, InstanceDecl p cx qcls ty $ fromPDecls $ map untyped opds ++ vpds')   where (vpds, opds) = partition (isValueDecl . snd) $ toPDecls ds tcTopPDecl _ = internalError "Checks.TypeCheck.tcTopDecl"@@ -882,7 +885,8 @@   checkClassMethodType qty tySc pd' tcClassMethodPDecl _ _ _ = internalError "TypeCheck.tcClassMethodPDecl" -tcInstanceMethodPDecl :: QualIdent -> PredType -> PDecl a -> TCM (PDecl PredType)+tcInstanceMethodPDecl :: QualIdent -> PredType -> PDecl a+                      -> TCM (PDecl PredType) tcInstanceMethodPDecl qcls pty pd@(_, FunctionDecl _ _ f _) = do   methTy <- instMethodType (qualifyLike qcls) pty f   (tySc, pd') <- tcMethodPDecl (typeScheme methTy) pd@@ -983,7 +987,8 @@ -- checked as constructor and functional patterns, respectively, resulting -- in slighty misleading error messages if the type check fails. -tcPattern :: HasPosition p => p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)+tcPattern :: HasPosition p => p -> Pattern a+          -> TCM (PredSet, Type, Pattern PredType) tcPattern _ (LiteralPattern spi _ l) = do   (ps, ty) <- tcLiteral False l   return (ps, ty, LiteralPattern spi (predType ty) l)@@ -998,11 +1003,12 @@   m <- getModuleIdent   vEnv <- getValueEnv   (ps, (tys, ty')) <- liftM (fmap arrowUnapply) (skol (constrType m c vEnv))-  (ps', ts') <- mapAccumM (uncurry . tcPatternArg p "pattern" (ppPattern 0 t)) ps (zip tys ts)+  (ps', ts') <- mapAccumM (uncurry . tcPatternArg p "pattern" (ppPattern 0 t))+                          ps (zip tys ts)   return (ps', ty', ConstructorPattern spi (predType ty') c ts') tcPattern p (InfixPattern spi a t1 op t2) = do-  (ps, ty, ConstructorPattern _ a' op' [t1', t2']) <--    tcPattern p (ConstructorPattern NoSpanInfo a op [t1, t2])+  (ps, ty, t') <- tcPattern p (ConstructorPattern NoSpanInfo a op [t1, t2])+  let ConstructorPattern _ a' op' [t1', t2'] = t'   return (ps, ty, InfixPattern spi a' t1' op' t2') tcPattern p (ParenPattern spi t) = do   (ps, ty, t') <- tcPattern p t@@ -1011,14 +1017,16 @@   m <- getModuleIdent   vEnv <- getValueEnv   (ps, ty) <- liftM (fmap arrowBase) (skol (constrType m c vEnv))-  (ps', fs') <- mapAccumM (tcField tcPattern "pattern" (\t' -> ppPattern 0 t $-$ text "Term:" <+> ppPattern 0 t') ty) ps fs+  (ps', fs') <- mapAccumM (tcField tcPattern "pattern"+    (\t' -> ppPattern 0 t $-$ text "Term:" <+> ppPattern 0 t') ty) ps fs   return (ps', ty, RecordPattern spi (predType ty) c fs') tcPattern p (TuplePattern spi ts) = do   (pss, tys, ts') <- liftM unzip3 $ mapM (tcPattern p) ts   return (Set.unions pss, tupleType tys, TuplePattern spi ts') tcPattern p t@(ListPattern spi _ ts) = do   ty <- freshTypeVar-  (ps, ts') <- mapAccumM (flip (tcPatternArg p "pattern" (ppPattern 0 t)) ty) emptyPredSet ts+  (ps, ts') <- mapAccumM (flip (tcPatternArg p "pattern" (ppPattern 0 t)) ty)+                         emptyPredSet ts   return (ps, listType ty, ListPattern spi (predType $ listType ty) ts') tcPattern p t@(AsPattern spi v t') = do   vEnv <- getValueEnv@@ -1035,8 +1043,8 @@   (ps, ty) <- inst (funType m f vEnv)   tcFuncPattern p spi (ppPattern 0 t) f id ps ty ts tcPattern p (InfixFuncPattern spi a t1 op t2) = do-  (ps, ty, FunctionPattern _ a' op' [t1', t2']) <--    tcPattern p (FunctionPattern spi a op [t1, t2])+  (ps, ty, t') <- tcPattern p (FunctionPattern spi a op [t1, t2])+  let FunctionPattern _ a' op' [t1', t2'] = t'   return (ps, ty, InfixFuncPattern spi a' t1' op' t2')  tcFuncPattern :: HasPosition p => p -> SpanInfo -> Doc -> QualIdent@@ -1078,7 +1086,8 @@   (ps'', e') <- tcExpr p e >>- unify p "guarded expression" (ppExpr 0 e) ps' ty   return (ps'', CondExpr p g' e') -tcExpr :: HasPosition p => p -> Expression a -> TCM (PredSet, Type, Expression PredType)+tcExpr :: HasPosition p => p -> Expression a+       -> TCM (PredSet, Type, Expression PredType) tcExpr _ (Literal spi _ l) = do   (ps, ty) <- tcLiteral True l   return (ps, ty, Literal spi (predType ty) l)@@ -1114,11 +1123,13 @@   m <- getModuleIdent   vEnv <- getValueEnv   (ps, ty) <- liftM (fmap arrowBase) (instExist (constrType m c vEnv))-  (ps', fs') <- mapAccumM (tcField tcExpr "construction" (\e' -> ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e') ty) ps fs+  (ps', fs') <- mapAccumM (tcField tcExpr "construction"+    (\e' -> ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e') ty) ps fs   return (ps', ty, Record spi (predType ty) c fs') tcExpr p e@(RecordUpdate spi e1 fs) = do   (ps, ty, e1') <- tcExpr p e1-  (ps', fs') <- mapAccumM (tcField tcExpr "update" (\e' -> ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e') ty) ps fs+  (ps', fs') <- mapAccumM (tcField tcExpr "update"+    (\e' -> ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e') ty) ps fs   return (ps', ty, RecordUpdate spi e1' fs') tcExpr p (Tuple spi es) = do   (pss, tys, es') <- liftM unzip3 $ mapM (tcExpr p) es@@ -1241,7 +1252,8 @@       tcPatternArg p "case pattern" (ppAlt (Alt p t rhs)) emptyPredSet tyLhs t     (ps', ty', rhs') <- tcRhs rhs     return (ps, t', ps', ty', rhs')-  ps'' <- reducePredSet p "alternative" (ppAlt (Alt p t' rhs')) (ps `Set.union` ps')+  ps'' <- reducePredSet p "alternative" (ppAlt (Alt p t' rhs'))+                        (ps `Set.union` ps')   checkSkolems p "Alternative" ppAlt fs ps'' ty' (Alt p t' rhs')  tcQual :: HasPosition p => p -> PredSet -> Statement a@@ -1300,7 +1312,8 @@ tcField check what doc ty ps (Field p l x) = do   m <- getModuleIdent   vEnv <- getValueEnv-  (ps', TypeArrow ty1 ty2) <- inst (labelType m l vEnv)+  (ps', ty') <- inst (labelType m l vEnv)+  let TypeArrow ty1 ty2 = ty'   _ <- unify p "field label" empty emptyPredSet ty emptyPredSet ty1   (ps'', x') <- check (spanInfo2Pos p) x >>-     unify p ("record " ++ what) (doc x) (ps `Set.union` ps') ty2@@ -1328,7 +1341,8 @@ -- The function 'tcBinary' checks that its argument can be used as an arrow type -- a -> b -> c and returns the triple (a,b,c). -tcBinary :: HasPosition p => p -> String -> Doc -> Type -> TCM (Type, Type, Type)+tcBinary :: HasPosition p => p -> String -> Doc -> Type+         -> TCM (Type, Type, Type) tcBinary p what doc ty = tcArrow p what doc ty >>= uncurry binaryArrow   where   binaryArrow ty1 (TypeArrow ty2 ty3) = return (ty1, ty2, ty3)@@ -1344,8 +1358,8 @@  -- Unification: The unification uses Robinson's algorithm. -unify :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> PredSet -> Type-      -> TCM PredSet+unify :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> PredSet+      -> Type -> TCM PredSet unify p what doc ps1 ty1 ps2 ty2 = do   theta <- getTypeSubst   let ty1' = subst theta ty1@@ -1441,8 +1455,8 @@       fmap (expandAliasType tys . snd3) (lookupInstInfo (qcls, tc) $ fst inEnv)     _ -> Nothing -reportMissingInstance :: HasPosition p => ModuleIdent -> p -> String -> Doc -> InstEnv'-                      -> TypeSubst -> Pred -> TCM TypeSubst+reportMissingInstance :: HasPosition p => ModuleIdent -> p -> String -> Doc+                      -> InstEnv' -> TypeSubst -> Pred -> TCM TypeSubst reportMissingInstance m p what doc inEnv theta (Pred qcls ty) =   case subst theta ty of     ty'@(TypeConstrained tys tv) ->@@ -1484,8 +1498,8 @@ -- types that satisfies all constraints for the ambiguous type variable. An -- error is reported if no such type exists. -applyDefaults :: HasPosition p => p -> String -> Doc -> Set.Set Int -> PredSet -> Type-              -> TCM PredSet+applyDefaults :: HasPosition p => p -> String -> Doc -> Set.Set Int -> PredSet+              -> Type -> TCM PredSet applyDefaults p what doc fvs ps ty = do   m <- getModuleIdent   clsEnv <- getClassEnv@@ -1529,8 +1543,8 @@ -- a skolem constant escapes in the (result) type of 'f' and in the type of the -- environment variable 'x' for the fcase expression in the definition of 'g'. -checkSkolems :: HasPosition p => p -> String -> (a -> Doc) -> Set.Set Int -> PredSet-             -> Type -> a -> TCM (PredSet, Type, a)+checkSkolems :: HasPosition p => p -> String -> (a -> Doc) -> Set.Set Int+             -> PredSet -> Type -> a -> TCM (PredSet, Type, a) checkSkolems p what pp fs ps ty x = do   m <- getModuleIdent   vEnv <- getValueEnv@@ -1755,15 +1769,16 @@   , text "Cannot be applied"   ] -errNonBinaryOp :: HasPosition a => a -> String -> Doc -> ModuleIdent -> Type -> Message+errNonBinaryOp :: HasPosition a => a -> String -> Doc -> ModuleIdent -> Type+               -> Message errNonBinaryOp p what doc m ty = posMessage p $ vcat   [ text "Type error in" <+> text what, doc   , text "Type:" <+> ppType m ty   , text "Cannot be used as binary operator"   ] -errTypeMismatch :: HasPosition a => a -> String -> Doc -> ModuleIdent -> Type -> Type-                -> Doc -> Message+errTypeMismatch :: HasPosition a => a -> String -> Doc -> ModuleIdent -> Type+                -> Type -> Doc -> Message errTypeMismatch p what doc m ty1 ty2 reason = posMessage p $ vcat   [ text "Type error in"  <+> text what, doc   , text "Inferred type:" <+> ppType m ty2@@ -1793,8 +1808,8 @@   , text "are incompatible"   ] -errIncompatibleLabelTypes :: HasPosition a => a -> ModuleIdent -> Ident -> Type -> Type-                          -> Message+errIncompatibleLabelTypes :: HasPosition a => a -> ModuleIdent -> Ident -> Type+                          -> Type -> Message errIncompatibleLabelTypes p m l ty1 ty2 = posMessage p $ sep   [ text "Labeled types" <+> ppIdent l <+> text "::" <+> ppType m ty1   , nest 10 $ text "and" <+> ppIdent l <+> text "::" <+> ppType m ty2@@ -1809,8 +1824,8 @@   , doc   ] -errAmbiguousTypeVariable :: HasPosition a => ModuleIdent -> a -> String -> Doc -> PredSet-                         -> Type -> Int -> Message+errAmbiguousTypeVariable :: HasPosition a => ModuleIdent -> a -> String -> Doc+                         -> PredSet -> Type -> Int -> Message errAmbiguousTypeVariable m p what doc ps ty tv = posMessage p $ vcat   [ text "Ambiguous type variable" <+> ppType m (TypeVariable tv)   , text "in type" <+> ppPredType m (PredType ps ty)
src/Checks/TypeSyntaxCheck.hs view
@@ -365,7 +365,8 @@   return $ ConstrDecl p evs cx' c tys' checkConstrDecl tvs (ConOpDecl p evs cx ty1 op ty2) = do   checkExistVars evs-  [ty1', ty2'] <- mapM (checkClosedType (evs ++ tvs)) [ty1, ty2]+  tys' <- mapM (checkClosedType (evs ++ tvs)) [ty1, ty2]+  let [ty1', ty2'] = tys'   cx' <- checkClosedContext (fv ty1' ++ fv ty2') cx   return $ ConOpDecl p evs cx' ty1' op ty2' checkConstrDecl tvs (RecordDecl p evs cx c fs) = do
src/Modules.hs view
@@ -45,7 +45,6 @@ import Curry.Files.PathUtils import Curry.Syntax.InterfaceEquivalence import Curry.Syntax.Utils (shortenModuleAST)-import Curry.Syntax.Lexer (Token(..), Category(..))  import Base.Messages import Base.Types
src/Transformations/Derive.hs view
@@ -253,7 +253,8 @@                    -> DVM (Decl PredType) deriveEnumFromThen ty (_, c1, _, _) (_, c2, _, _) ps = do   pty <- getInstMethodType ps qEnumId ty enumFromId-  vs@[v1, v2] <- mapM (freshArgument . instType) $ replicate 2 ty+  vs  <- mapM (freshArgument . instType) $ replicate 2 ty+  let [v1, v2] = vs   return $ funDecl NoSpanInfo pty enumFromThenId     (map (uncurry (VariablePattern NoSpanInfo)) vs) $     enumFromThenExpr v1 v2 c1 c2
src/Transformations/Desugar.hs view
@@ -375,8 +375,8 @@   second (ListPattern NoSpanInfo pty) <$> mapAccumM dsNonLinear env ts dsNonLinear env (AsPattern               _ v t) = do   let pty = predType $ typeOf t-  (env1, VariablePattern _ _ v') <--    dsNonLinear env (VariablePattern NoSpanInfo pty v)+  (env1, pat) <- dsNonLinear env (VariablePattern NoSpanInfo pty v)+  let VariablePattern _ _ v' = pat   (env2, t') <- dsNonLinear env1 t   return (env2, AsPattern NoSpanInfo v' t') dsNonLinear env (LazyPattern               _ t) =
src/Transformations/Lift.hs view
@@ -245,7 +245,8 @@            -> LiftM (Decl Type) absFunDecl pre fvs lvs (FunctionDecl p _ f eqs) = do   m <- getModuleIdent-  FunctionDecl _ _ _ eqs'' <- absDecl pre lvs $ FunctionDecl p undefined f' eqs'+  d <- absDecl pre lvs $ FunctionDecl p undefined f' eqs'+  let FunctionDecl _ _ _ eqs'' = d   modifyValueEnv $ bindGlobalInfo     (\qf tySc -> Value qf False (eqnArity $ head eqs') tySc) m f' $ polyType ty''   return $ FunctionDecl p ty'' f' eqs''