Commit 40e4249d authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky

Undid recent changes in TypeCheck.hs to make bootstrapping work again

parent 0f3765d6
...@@ -4,10 +4,6 @@ Change log for curry-frontend ...@@ -4,10 +4,6 @@ Change log for curry-frontend
Under development 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 * Replaced MessageM monad with CYT monads and moved CYT monads to curry-base
* Implemented warnings for overlapping module aliases - fixes #14 * Implemented warnings for overlapping module aliases - fixes #14
......
...@@ -185,15 +185,10 @@ checkTypeDecls _ [] = ...@@ -185,15 +185,10 @@ checkTypeDecls _ [] =
internalError "TypeCheck.checkTypeDecls: empty list" internalError "TypeCheck.checkTypeDecls: empty list"
checkTypeDecls _ [DataDecl _ _ _ _] = return () checkTypeDecls _ [DataDecl _ _ _ _] = return ()
checkTypeDecls _ [NewtypeDecl _ _ _ _] = return () checkTypeDecls _ [NewtypeDecl _ _ _ _] = return ()
checkTypeDecls m [t@(TypeDecl _ tc _ ty)] checkTypeDecls m [TypeDecl _ tc _ ty]
-- allow recursive record declarations
| isRecordDecl t = return ()
| tc `elem` ft m ty [] = report $ errRecursiveTypes [tc] | tc `elem` ft m ty [] = report $ errRecursiveTypes [tc]
| otherwise = return () | otherwise = return ()
checkTypeDecls _ (t@(TypeDecl _ tc _ _) : ds) checkTypeDecls _ (TypeDecl _ tc _ _ : ds) =
-- allow mutually recursive record declarations
| isRecordDecl t || any isRecordDecl ds = return ()
| otherwise =
report $ errRecursiveTypes $ tc : [tc' | TypeDecl _ tc' _ _ <- ds] report $ errRecursiveTypes $ tc : [tc' | TypeDecl _ tc' _ _ <- ds]
checkTypeDecls _ _ = checkTypeDecls _ _ =
internalError "TypeCheck.checkTypeDecls: no type synonym" internalError "TypeCheck.checkTypeDecls: no type synonym"
...@@ -621,17 +616,18 @@ tcPattern p t@(FunctionPattern f ts) = do ...@@ -621,17 +616,18 @@ tcPattern p t@(FunctionPattern f ts) = do
unifyArgs _ _ ty = internalError $ "TypeCheck.tcPattern: " ++ show ty unifyArgs _ _ ty = internalError $ "TypeCheck.tcPattern: " ++ show ty
tcPattern p (InfixFuncPattern t1 op t2) = tcPattern p (InfixFuncPattern t1 op t2) =
tcPattern p (FunctionPattern op [t1,t2]) tcPattern p (FunctionPattern op [t1,t2])
tcPattern p r@(RecordPattern fs _) = do tcPattern p r@(RecordPattern fs rt) =
recInfo <- getFieldIdent fs >>= getRecordInfo case rt of
case recInfo of Just ty -> do
[AliasType qi n rty@(TypeRecord _ _)] -> do ty' <- tcPattern p ty
(rty'@(TypeRecord fts' _), tys) <- inst' (ForAll n rty)
fts <- mapM (tcFieldPatt tcPattern) fs fts <- mapM (tcFieldPatt tcPattern) fs
unifyLabels p "record pattern" (ppPattern 0 r) fts' rty' fts alpha <- freshVar id
theta <- getTypeSubst let rty = TypeRecord fts (Just alpha)
return (subst theta $ TypeConstructor qi tys) unify p "record pattern" (ppPattern 0 r) ty' rty
info -> internalError $ "TypeCheck.tcExpr: Expected record type but got " return rty
++ show info Nothing -> do
fts <- mapM (tcFieldPatt tcPattern) fs
return (TypeRecord fts Nothing)
-- In contrast to usual patterns, the type checking routine for arguments of -- In contrast to usual patterns, the type checking routine for arguments of
-- function patterns 'tcPatternFP' differs from 'tcPattern' -- function patterns 'tcPatternFP' differs from 'tcPattern'
...@@ -714,17 +710,18 @@ tcPatternFP p t@(FunctionPattern f ts) = do ...@@ -714,17 +710,18 @@ tcPatternFP p t@(FunctionPattern f ts) = do
unifyArgs _ _ _ = internalError "TypeCheck.tcPatternFP" unifyArgs _ _ _ = internalError "TypeCheck.tcPatternFP"
tcPatternFP p (InfixFuncPattern t1 op t2) = tcPatternFP p (InfixFuncPattern t1 op t2) =
tcPatternFP p (FunctionPattern op [t1,t2]) tcPatternFP p (FunctionPattern op [t1,t2])
tcPatternFP p r@(RecordPattern fs _) = do tcPatternFP p r@(RecordPattern fs rt) =
recInfo <- getFieldIdent fs >>= getRecordInfo case rt of
case recInfo of Just ty -> do
[AliasType qi n rty@(TypeRecord _ _)] -> do ty' <- tcPatternFP p ty
(rty'@(TypeRecord fts' _), tys) <- inst' (ForAll n rty) fts <- mapM (tcFieldPatt tcPatternFP) fs
fts <- mapM (tcFieldPatt tcPattern) fs alpha <- freshVar id
unifyLabels p "record pattern" (ppPattern 0 r) fts' rty' fts let rty = TypeRecord fts (Just alpha)
theta <- getTypeSubst unify p "record pattern" (ppPattern 0 r) ty' rty
return (subst theta $ TypeConstructor qi tys) return rty
info -> internalError $ "TypeCheck.tcExpr: Expected record type but got " Nothing -> do
++ show info fts <- mapM (tcFieldPatt tcPatternFP) fs
return (TypeRecord fts Nothing)
tcFieldPatt :: (Position -> Pattern -> TCM Type) -> Field Pattern tcFieldPatt :: (Position -> Pattern -> TCM Type) -> Field Pattern
-> TCM (Ident, Type) -> TCM (Ident, Type)
...@@ -932,49 +929,23 @@ tcExpr p (Case _ _ e alts) = do ...@@ -932,49 +929,23 @@ tcExpr p (Case _ _ e alts) = do
ty1 >> ty1 >>
tcRhs tyEnv0 rhs >>= tcRhs tyEnv0 rhs >>=
unify p1 "case branch" doc ty2 unify p1 "case branch" doc ty2
tcExpr p r@(RecordConstr fs) = do tcExpr _ (RecordConstr fs) = do
recInfo <- getFieldIdent fs >>= getRecordInfo fts <- mapM tcFieldExpr fs
case recInfo of return (TypeRecord fts Nothing)
[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 p r@(RecordSelection e l) = do tcExpr p r@(RecordSelection e l) = do
recInfo <- getRecordInfo l lty <- instLabel l
case recInfo of ety <- tcExpr p e
[AliasType qi n rty@(TypeRecord _ _)] -> do alpha <- freshVar id
ety <- tcExpr p e let rty = TypeRecord [(l, lty)] (Just alpha)
(TypeRecord fts _, tys) <- inst' (ForAll n rty) unify p "record selection" (ppExpr 0 r) ety rty
let rtc = TypeConstructor qi tys return lty
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
tcExpr p r@(RecordUpdate fs e) = do tcExpr p r@(RecordUpdate fs e) = do
recInfo <- getFieldIdent fs >>= getRecordInfo ty <- tcExpr p e
case recInfo of fts <- mapM tcFieldExpr fs
[AliasType qi n rty@(TypeRecord _ _)] -> do alpha <- freshVar id
(rty'@(TypeRecord fts' _), tys) <- inst' (ForAll n rty) let rty = TypeRecord fts (Just alpha)
-- Type check field updates unify p "record update" (ppExpr 0 r) ty rty
fts <- mapM tcFieldExpr fs return ty
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
tcQual :: Position -> Statement -> TCM () tcQual :: Position -> Statement -> TCM ()
tcQual p (StmtExpr _ e) = tcQual p (StmtExpr _ e) =
...@@ -1092,39 +1063,34 @@ unifyTypes _ _ (TypeSkolem k1) (TypeSkolem k2) ...@@ -1092,39 +1063,34 @@ unifyTypes _ _ (TypeSkolem k1) (TypeSkolem k2)
unifyTypes m tcEnv (TypeRecord fs1 Nothing) tr2@(TypeRecord fs2 Nothing) unifyTypes m tcEnv (TypeRecord fs1 Nothing) tr2@(TypeRecord fs2 Nothing)
| length fs1 == length fs2 = unifyTypedLabels m tcEnv fs1 tr2 | length fs1 == length fs2 = unifyTypedLabels m tcEnv fs1 tr2
unifyTypes m _ ty1 ty2 = Left (errIncompatibleTypes m ty1 ty2) unifyTypes m _ ty1 ty2 = Left (errIncompatibleTypes m ty1 ty2)
unifyTypes m tcEnv tr1@(TypeRecord _ Nothing) (TypeRecord fs2 (Just a2)) =
-- bjp 2014-10-08: Deactivated because the parser can not parse either Left
-- record extensions, thus, these cases should never occur. If they do, (\res -> either Left
-- there must be an error somewhere ... (Right . compose res)
(unifyTypes m tcEnv (TypeVariable a2) tr1))
-- unifyTypes m tcEnv tr1@(TypeRecord _ Nothing) (TypeRecord fs2 (Just a2)) = (unifyTypedLabels m tcEnv fs2 tr1)
-- either Left unifyTypes m tcEnv tr1@(TypeRecord _ (Just _)) tr2@(TypeRecord _ Nothing) =
-- (\res -> either Left unifyTypes m tcEnv tr2 tr1
-- (Right . compose res) unifyTypes m tcEnv (TypeRecord fs1 (Just a1)) tr2@(TypeRecord fs2 (Just a2)) =
-- (unifyTypes m tcEnv (TypeVariable a2) tr1)) let (fs1', rs1, rs2) = splitFields fs1 fs2
-- (unifyTypedLabels m tcEnv fs2 tr1) in either
-- unifyTypes m tcEnv tr1@(TypeRecord _ (Just _)) tr2@(TypeRecord _ Nothing) = Left
-- unifyTypes m tcEnv tr2 tr1 (\res ->
-- unifyTypes m tcEnv (TypeRecord fs1 (Just a1)) tr2@(TypeRecord fs2 (Just a2)) = either
-- let (fs1', rs1, rs2) = splitFields fs1 fs2 Left
-- in either (\res' -> Right (compose res res'))
-- Left (unifyTypeLists m tcEnv [TypeVariable a1,
-- (\res -> TypeRecord (fs1 ++ rs2) Nothing]
-- either [TypeVariable a2,
-- Left TypeRecord (fs2 ++ rs1) Nothing]))
-- (\res' -> Right (compose res res')) (unifyTypedLabels m tcEnv fs1' tr2)
-- (unifyTypeLists m tcEnv [TypeVariable a1, where
-- TypeRecord (fs1 ++ rs2) Nothing] splitFields fsx fsy = split' [] [] fsy fsx
-- [TypeVariable a2, split' fs1' rs1 rs2 [] = (fs1',rs1,rs2)
-- TypeRecord (fs2 ++ rs1) Nothing])) split' fs1' rs1 rs2 ((l,ty):ltys) =
-- (unifyTypedLabels m tcEnv fs1' tr2) maybe (split' fs1' ((l,ty):rs1) rs2 ltys)
-- where (const (split' ((l,ty):fs1') rs1 (remove l rs2) ltys))
-- splitFields fsx fsy = split' [] [] fsy fsx (lookup l rs2)
-- 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 :: ModuleIdent -> TCEnv -> [Type] -> [Type] -> Either Doc TypeSubst
unifyTypeLists _ _ [] _ = Right idSubst unifyTypeLists _ _ [] _ = Right idSubst
...@@ -1135,15 +1101,15 @@ unifyTypeLists m tcEnv (ty1 : tys1) (ty2 : tys2) = ...@@ -1135,15 +1101,15 @@ unifyTypeLists m tcEnv (ty1 : tys1) (ty2 : tys2) =
either Left (Right . flip compose theta) either Left (Right . flip compose theta)
(unifyTypes m tcEnv (subst theta ty1) (subst theta ty2)) (unifyTypes m tcEnv (subst theta ty1) (subst theta ty2))
unifyLabels :: Position -> String -> Doc -> [(Ident, Type)] -> Type -> [(Ident, Type)] -> TCM () -- 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 -- 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 :: Position -> String -> Doc -> [(Ident, Type)] -> Type -> (Ident, Type) -> TCM ()
unifyLabel p what doc fs rty (l, ty) = case lookup l fs of -- unifyLabel p what doc fs rty (l, ty) = case lookup l fs of
Nothing -> do -- Nothing -> do
m <- getModuleIdent -- m <- getModuleIdent
report $ posMessage p $ errMissingLabel m l rty -- report $ posMessage p $ errMissingLabel m l rty
Just ty' -> unify p what doc ty' ty -- Just ty' -> unify p what doc ty' ty
unifyTypedLabels :: ModuleIdent -> TCEnv -> [(Ident,Type)] -> Type unifyTypedLabels :: ModuleIdent -> TCEnv -> [(Ident,Type)] -> Type
-> Either Doc TypeSubst -> Either Doc TypeSubst
...@@ -1190,10 +1156,10 @@ freshConstrained = freshVar . TypeConstrained ...@@ -1190,10 +1156,10 @@ freshConstrained = freshVar . TypeConstrained
freshSkolem :: TCM Type freshSkolem :: TCM Type
freshSkolem = fresh TypeSkolem freshSkolem = fresh TypeSkolem
inst' :: TypeScheme -> TCM (Type, [Type]) -- inst' :: TypeScheme -> TCM (Type, [Type])
inst' (ForAll n ty) = do -- inst' (ForAll n ty) = do
tys <- replicateM n freshTypeVar -- tys <- replicateM n freshTypeVar
return (expandAliasType tys ty, tys) -- return (expandAliasType tys ty, tys)
inst :: TypeScheme -> TCM Type inst :: TypeScheme -> TCM Type
inst (ForAll n ty) = do inst (ForAll n ty) = do
...@@ -1298,12 +1264,12 @@ expandType :: ModuleIdent -> TCEnv -> Type -> Type ...@@ -1298,12 +1264,12 @@ expandType :: ModuleIdent -> TCEnv -> Type -> Type
expandType m tcEnv (TypeConstructor tc tys) = case qualLookupTC tc tcEnv of expandType m tcEnv (TypeConstructor tc tys) = case qualLookupTC tc tcEnv of
[DataType tc' _ _] -> TypeConstructor tc' tys' [DataType tc' _ _] -> TypeConstructor tc' tys'
[RenamingType 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 [AliasType _ _ ty] -> expandAliasType tys' ty
_ -> case qualLookupTC (qualQualify m tc) tcEnv of _ -> case qualLookupTC (qualQualify m tc) tcEnv of
[DataType tc' _ _ ] -> TypeConstructor tc' tys' [DataType tc' _ _ ] -> TypeConstructor tc' tys'
[RenamingType 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 [AliasType _ _ ty] -> expandAliasType tys' ty
_ -> internalError $ "TypeCheck.expandType " ++ show tc _ -> internalError $ "TypeCheck.expandType " ++ show tc
where tys' = map (expandType m tcEnv) tys where tys' = map (expandType m tcEnv) tys
...@@ -1329,29 +1295,29 @@ fsEnv = Set.unions . map (Set.fromList . typeSkolems) . localTypes ...@@ -1329,29 +1295,29 @@ fsEnv = Set.unions . map (Set.fromList . typeSkolems) . localTypes
localTypes :: ValueEnv -> [Type] localTypes :: ValueEnv -> [Type]
localTypes tyEnv = [ty | (_, Value _ _ (ForAll _ ty)) <- localBindings tyEnv] localTypes tyEnv = [ty | (_, Value _ _ (ForAll _ ty)) <- localBindings tyEnv]
getFieldIdent :: [Field a] -> TCM Ident -- getFieldIdent :: [Field a] -> TCM Ident
getFieldIdent [] = internalError "TypeCheck.getFieldIdent: empty field" -- getFieldIdent [] = internalError "TypeCheck.getFieldIdent: empty field"
getFieldIdent (Field _ i _ : _) = return i -- getFieldIdent (Field _ i _ : _) = return i
-- Lookup record type for given field identifier -- Lookup record type for given field identifier
getRecordInfo :: Ident -> TCM [TypeInfo] -- getRecordInfo :: Ident -> TCM [TypeInfo]
getRecordInfo i = do -- getRecordInfo i = do
tyEnv <- getValueEnv -- tyEnv <- getValueEnv
tcEnv <- getTyConsEnv -- tcEnv <- getTyConsEnv
case lookupValue i tyEnv of -- case lookupValue i tyEnv of
[Label _ r _] -> return (qualLookupTC r tcEnv) -- [Label _ r _] -> return (qualLookupTC r tcEnv)
_ -> internalError $ -- _ -> internalError $
"TypeCheck.getRecordInfo: No record found for identifier " ++ show i -- "TypeCheck.getRecordInfo: No record found for identifier " ++ show i
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
-- Miscellaneous functions -- Miscellaneous functions
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
-- remove :: Eq a => a -> [(a, b)] -> [(a, b)] remove :: Eq a => a -> [(a, b)] -> [(a, b)]
-- remove _ [] = [] remove _ [] = []
-- remove k (kv : kvs) remove k (kv : kvs)
-- | k == fst kv = kvs | k == fst kv = kvs
-- | otherwise = kv : remove k kvs | otherwise = kv : remove k kvs
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
-- Error functions -- Error functions
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment