From 40e4249d48bd94433fcef9b13b2a042f3cf17bb3 Mon Sep 17 00:00:00 2001 From: Jan Tikovsky Date: Wed, 15 Oct 2014 09:46:30 +0200 Subject: [PATCH] Undid recent changes in TypeCheck.hs to make bootstrapping work again --- CHANGELOG.md | 4 - src/Checks/TypeCheck.hs | 232 +++++++++++++++++----------------------- 2 files changed, 99 insertions(+), 137 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 3f04374c..5cb30805 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,10 +4,6 @@ Change log for curry-frontend Under development ================= - * Enabled declaration of (mutually) recursive record types - - * Removed expansion of record types in type error messages - * Replaced MessageM monad with CYT monads and moved CYT monads to curry-base * Implemented warnings for overlapping module aliases - fixes #14 diff --git a/src/Checks/TypeCheck.hs b/src/Checks/TypeCheck.hs index 7007ebff..466be6f8 100644 --- a/src/Checks/TypeCheck.hs +++ b/src/Checks/TypeCheck.hs @@ -185,15 +185,10 @@ checkTypeDecls _ [] = internalError "TypeCheck.checkTypeDecls: empty list" checkTypeDecls _ [DataDecl _ _ _ _] = return () checkTypeDecls _ [NewtypeDecl _ _ _ _] = return () -checkTypeDecls m [t@(TypeDecl _ tc _ ty)] - -- allow recursive record declarations - | isRecordDecl t = return () +checkTypeDecls m [TypeDecl _ tc _ ty] | tc `elem` ft m ty [] = report $ errRecursiveTypes [tc] | otherwise = return () -checkTypeDecls _ (t@(TypeDecl _ tc _ _) : ds) - -- allow mutually recursive record declarations - | isRecordDecl t || any isRecordDecl ds = return () - | otherwise = +checkTypeDecls _ (TypeDecl _ tc _ _ : ds) = report $ errRecursiveTypes $ tc : [tc' | TypeDecl _ tc' _ _ <- ds] checkTypeDecls _ _ = internalError "TypeCheck.checkTypeDecls: no type synonym" @@ -621,17 +616,18 @@ tcPattern p t@(FunctionPattern f ts) = do unifyArgs _ _ ty = internalError $ "TypeCheck.tcPattern: " ++ show ty tcPattern p (InfixFuncPattern t1 op t2) = tcPattern p (FunctionPattern op [t1,t2]) -tcPattern p r@(RecordPattern fs _) = do - recInfo <- getFieldIdent fs >>= getRecordInfo - case recInfo of - [AliasType qi n rty@(TypeRecord _ _)] -> do - (rty'@(TypeRecord fts' _), tys) <- inst' (ForAll n rty) +tcPattern p r@(RecordPattern fs rt) = + case rt of + Just ty -> do + ty' <- tcPattern p ty fts <- mapM (tcFieldPatt tcPattern) fs - unifyLabels p "record pattern" (ppPattern 0 r) fts' rty' fts - theta <- getTypeSubst - return (subst theta $ TypeConstructor qi tys) - info -> internalError $ "TypeCheck.tcExpr: Expected record type but got " - ++ show info + alpha <- freshVar id + let rty = TypeRecord fts (Just alpha) + unify p "record pattern" (ppPattern 0 r) ty' rty + return rty + Nothing -> do + fts <- mapM (tcFieldPatt tcPattern) fs + return (TypeRecord fts Nothing) -- In contrast to usual patterns, the type checking routine for arguments of -- function patterns 'tcPatternFP' differs from 'tcPattern' @@ -714,17 +710,18 @@ tcPatternFP p t@(FunctionPattern f ts) = do unifyArgs _ _ _ = internalError "TypeCheck.tcPatternFP" tcPatternFP p (InfixFuncPattern t1 op t2) = tcPatternFP p (FunctionPattern op [t1,t2]) -tcPatternFP p r@(RecordPattern fs _) = do - recInfo <- getFieldIdent fs >>= getRecordInfo - case recInfo of - [AliasType qi n rty@(TypeRecord _ _)] -> do - (rty'@(TypeRecord fts' _), tys) <- inst' (ForAll n rty) - fts <- mapM (tcFieldPatt tcPattern) fs - unifyLabels p "record pattern" (ppPattern 0 r) fts' rty' fts - theta <- getTypeSubst - return (subst theta $ TypeConstructor qi tys) - info -> internalError $ "TypeCheck.tcExpr: Expected record type but got " - ++ show info +tcPatternFP p r@(RecordPattern fs rt) = + case rt of + Just ty -> do + ty' <- tcPatternFP p ty + fts <- mapM (tcFieldPatt tcPatternFP) fs + alpha <- freshVar id + let rty = TypeRecord fts (Just alpha) + unify p "record pattern" (ppPattern 0 r) ty' rty + return rty + Nothing -> do + fts <- mapM (tcFieldPatt tcPatternFP) fs + return (TypeRecord fts Nothing) tcFieldPatt :: (Position -> Pattern -> TCM Type) -> Field Pattern -> TCM (Ident, Type) @@ -932,49 +929,23 @@ tcExpr p (Case _ _ e alts) = do ty1 >> tcRhs tyEnv0 rhs >>= unify p1 "case branch" doc ty2 -tcExpr p r@(RecordConstr fs) = do - recInfo <- getFieldIdent fs >>= getRecordInfo - case recInfo of - [AliasType qi n rty@(TypeRecord _ _)] -> do - (rty'@(TypeRecord fts' _), tys) <- inst' (ForAll n rty) - fts <- mapM tcFieldExpr fs - unifyLabels p "record construction" (ppExpr 0 r) fts' rty' fts - theta <- getTypeSubst - return (subst theta $ TypeConstructor qi tys) - info -> internalError $ "TypeCheck.tcExpr: Expected record type but got " - ++ show info +tcExpr _ (RecordConstr fs) = do + fts <- mapM tcFieldExpr fs + return (TypeRecord fts Nothing) tcExpr p r@(RecordSelection e l) = do - recInfo <- getRecordInfo l - case recInfo of - [AliasType qi n rty@(TypeRecord _ _)] -> do - ety <- tcExpr p e - (TypeRecord fts _, tys) <- inst' (ForAll n rty) - let rtc = TypeConstructor qi tys - case lookup l fts of - Just lty -> do - unify p "record selection" (ppExpr 0 r) ety rtc - theta <- getTypeSubst - return (subst theta lty) - Nothing -> internalError "TypeCheck.tcExpr: Field not found." - info -> internalError $ "TypeCheck.tcExpr: Expected record type but got " - ++ show info + lty <- instLabel l + ety <- tcExpr p e + alpha <- freshVar id + let rty = TypeRecord [(l, lty)] (Just alpha) + unify p "record selection" (ppExpr 0 r) ety rty + return lty tcExpr p r@(RecordUpdate fs e) = do - recInfo <- getFieldIdent fs >>= getRecordInfo - case recInfo of - [AliasType qi n rty@(TypeRecord _ _)] -> do - (rty'@(TypeRecord fts' _), tys) <- inst' (ForAll n rty) - -- Type check field updates - fts <- mapM tcFieldExpr fs - unifyLabels p "record update" (ppExpr 0 r) fts' rty' fts - -- Type check record expression to be updated - ety <- tcExpr p e - let rtc = TypeConstructor qi tys - unify p "record update" (ppExpr 0 r) ety rtc - -- Return inferred type - theta <- getTypeSubst - return (subst theta rtc) - info -> internalError $ "TypeCheck.tcExpr: Expected record type but got " - ++ show info + ty <- tcExpr p e + fts <- mapM tcFieldExpr fs + alpha <- freshVar id + let rty = TypeRecord fts (Just alpha) + unify p "record update" (ppExpr 0 r) ty rty + return ty tcQual :: Position -> Statement -> TCM () tcQual p (StmtExpr _ e) = @@ -1092,39 +1063,34 @@ unifyTypes _ _ (TypeSkolem k1) (TypeSkolem k2) unifyTypes m tcEnv (TypeRecord fs1 Nothing) tr2@(TypeRecord fs2 Nothing) | length fs1 == length fs2 = unifyTypedLabels m tcEnv fs1 tr2 unifyTypes m _ ty1 ty2 = Left (errIncompatibleTypes m ty1 ty2) - --- bjp 2014-10-08: Deactivated because the parser can not parse --- record extensions, thus, these cases should never occur. If they do, --- there must be an error somewhere ... - --- unifyTypes m tcEnv tr1@(TypeRecord _ Nothing) (TypeRecord fs2 (Just a2)) = --- either Left --- (\res -> either Left --- (Right . compose res) --- (unifyTypes m tcEnv (TypeVariable a2) tr1)) --- (unifyTypedLabels m tcEnv fs2 tr1) --- unifyTypes m tcEnv tr1@(TypeRecord _ (Just _)) tr2@(TypeRecord _ Nothing) = --- unifyTypes m tcEnv tr2 tr1 --- unifyTypes m tcEnv (TypeRecord fs1 (Just a1)) tr2@(TypeRecord fs2 (Just a2)) = --- let (fs1', rs1, rs2) = splitFields fs1 fs2 --- in either --- Left --- (\res -> --- either --- Left --- (\res' -> Right (compose res res')) --- (unifyTypeLists m tcEnv [TypeVariable a1, --- TypeRecord (fs1 ++ rs2) Nothing] --- [TypeVariable a2, --- TypeRecord (fs2 ++ rs1) Nothing])) --- (unifyTypedLabels m tcEnv fs1' tr2) --- where --- splitFields fsx fsy = split' [] [] fsy fsx --- split' fs1' rs1 rs2 [] = (fs1',rs1,rs2) --- split' fs1' rs1 rs2 ((l,ty):ltys) = --- maybe (split' fs1' ((l,ty):rs1) rs2 ltys) --- (const (split' ((l,ty):fs1') rs1 (remove l rs2) ltys)) --- (lookup l rs2) +unifyTypes m tcEnv tr1@(TypeRecord _ Nothing) (TypeRecord fs2 (Just a2)) = + either Left + (\res -> either Left + (Right . compose res) + (unifyTypes m tcEnv (TypeVariable a2) tr1)) + (unifyTypedLabels m tcEnv fs2 tr1) +unifyTypes m tcEnv tr1@(TypeRecord _ (Just _)) tr2@(TypeRecord _ Nothing) = + unifyTypes m tcEnv tr2 tr1 +unifyTypes m tcEnv (TypeRecord fs1 (Just a1)) tr2@(TypeRecord fs2 (Just a2)) = + let (fs1', rs1, rs2) = splitFields fs1 fs2 + in either + Left + (\res -> + either + Left + (\res' -> Right (compose res res')) + (unifyTypeLists m tcEnv [TypeVariable a1, + TypeRecord (fs1 ++ rs2) Nothing] + [TypeVariable a2, + TypeRecord (fs2 ++ rs1) Nothing])) + (unifyTypedLabels m tcEnv fs1' tr2) + where + splitFields fsx fsy = split' [] [] fsy fsx + split' fs1' rs1 rs2 [] = (fs1',rs1,rs2) + split' fs1' rs1 rs2 ((l,ty):ltys) = + maybe (split' fs1' ((l,ty):rs1) rs2 ltys) + (const (split' ((l,ty):fs1') rs1 (remove l rs2) ltys)) + (lookup l rs2) unifyTypeLists :: ModuleIdent -> TCEnv -> [Type] -> [Type] -> Either Doc TypeSubst unifyTypeLists _ _ [] _ = Right idSubst @@ -1135,15 +1101,15 @@ unifyTypeLists m tcEnv (ty1 : tys1) (ty2 : tys2) = either Left (Right . flip compose theta) (unifyTypes m tcEnv (subst theta ty1) (subst theta ty2)) -unifyLabels :: Position -> String -> Doc -> [(Ident, Type)] -> Type -> [(Ident, Type)] -> TCM () -unifyLabels p what doc fs rty fs1 = mapM_ (unifyLabel p what doc fs rty) fs1 - -unifyLabel :: Position -> String -> Doc -> [(Ident, Type)] -> Type -> (Ident, Type) -> TCM () -unifyLabel p what doc fs rty (l, ty) = case lookup l fs of - Nothing -> do - m <- getModuleIdent - report $ posMessage p $ errMissingLabel m l rty - Just ty' -> unify p what doc ty' ty +-- unifyLabels :: Position -> String -> Doc -> [(Ident, Type)] -> Type -> [(Ident, Type)] -> TCM () +-- unifyLabels p what doc fs rty fs1 = mapM_ (unifyLabel p what doc fs rty) fs1 +-- +-- unifyLabel :: Position -> String -> Doc -> [(Ident, Type)] -> Type -> (Ident, Type) -> TCM () +-- unifyLabel p what doc fs rty (l, ty) = case lookup l fs of +-- Nothing -> do +-- m <- getModuleIdent +-- report $ posMessage p $ errMissingLabel m l rty +-- Just ty' -> unify p what doc ty' ty unifyTypedLabels :: ModuleIdent -> TCEnv -> [(Ident,Type)] -> Type -> Either Doc TypeSubst @@ -1190,10 +1156,10 @@ freshConstrained = freshVar . TypeConstrained freshSkolem :: TCM Type freshSkolem = fresh TypeSkolem -inst' :: TypeScheme -> TCM (Type, [Type]) -inst' (ForAll n ty) = do - tys <- replicateM n freshTypeVar - return (expandAliasType tys ty, tys) +-- inst' :: TypeScheme -> TCM (Type, [Type]) +-- inst' (ForAll n ty) = do +-- tys <- replicateM n freshTypeVar +-- return (expandAliasType tys ty, tys) inst :: TypeScheme -> TCM Type inst (ForAll n ty) = do @@ -1298,12 +1264,12 @@ expandType :: ModuleIdent -> TCEnv -> Type -> Type expandType m tcEnv (TypeConstructor tc tys) = case qualLookupTC tc tcEnv of [DataType tc' _ _] -> TypeConstructor tc' tys' [RenamingType tc' _ _] -> TypeConstructor tc' tys' - [AliasType tc' _ (TypeRecord _ _)] -> TypeConstructor tc' tys' +-- [AliasType tc' _ (TypeRecord _ _)] -> TypeConstructor tc' tys' [AliasType _ _ ty] -> expandAliasType tys' ty _ -> case qualLookupTC (qualQualify m tc) tcEnv of [DataType tc' _ _ ] -> TypeConstructor tc' tys' [RenamingType tc' _ _ ] -> TypeConstructor tc' tys' - [AliasType tc' _ (TypeRecord _ _)] -> TypeConstructor tc' tys' +-- [AliasType tc' _ (TypeRecord _ _)] -> TypeConstructor tc' tys' [AliasType _ _ ty] -> expandAliasType tys' ty _ -> internalError $ "TypeCheck.expandType " ++ show tc where tys' = map (expandType m tcEnv) tys @@ -1329,29 +1295,29 @@ fsEnv = Set.unions . map (Set.fromList . typeSkolems) . localTypes localTypes :: ValueEnv -> [Type] localTypes tyEnv = [ty | (_, Value _ _ (ForAll _ ty)) <- localBindings tyEnv] -getFieldIdent :: [Field a] -> TCM Ident -getFieldIdent [] = internalError "TypeCheck.getFieldIdent: empty field" -getFieldIdent (Field _ i _ : _) = return i +-- getFieldIdent :: [Field a] -> TCM Ident +-- getFieldIdent [] = internalError "TypeCheck.getFieldIdent: empty field" +-- getFieldIdent (Field _ i _ : _) = return i -- Lookup record type for given field identifier -getRecordInfo :: Ident -> TCM [TypeInfo] -getRecordInfo i = do - tyEnv <- getValueEnv - tcEnv <- getTyConsEnv - case lookupValue i tyEnv of - [Label _ r _] -> return (qualLookupTC r tcEnv) - _ -> internalError $ - "TypeCheck.getRecordInfo: No record found for identifier " ++ show i +-- getRecordInfo :: Ident -> TCM [TypeInfo] +-- getRecordInfo i = do +-- tyEnv <- getValueEnv +-- tcEnv <- getTyConsEnv +-- case lookupValue i tyEnv of +-- [Label _ r _] -> return (qualLookupTC r tcEnv) +-- _ -> internalError $ +-- "TypeCheck.getRecordInfo: No record found for identifier " ++ show i -- --------------------------------------------------------------------------- -- Miscellaneous functions -- --------------------------------------------------------------------------- --- remove :: Eq a => a -> [(a, b)] -> [(a, b)] --- remove _ [] = [] --- remove k (kv : kvs) --- | k == fst kv = kvs --- | otherwise = kv : remove k kvs +remove :: Eq a => a -> [(a, b)] -> [(a, b)] +remove _ [] = [] +remove k (kv : kvs) + | k == fst kv = kvs + | otherwise = kv : remove k kvs -- --------------------------------------------------------------------------- -- Error functions -- GitLab