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

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

parent 0f3765d6
......@@ -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
......
......@@ -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
......
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