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

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

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)
+tcExpr _ (RecordConstr fs) = do
   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
+  return (TypeRecord fts Nothing)
 tcExpr p r@(RecordSelection e l) = do
-  recInfo <- getRecordInfo l
-  case recInfo of
-       [AliasType qi n rty@(TypeRecord _ _)] -> do
+  lty <- instLabel l
   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
+  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
+  ty    <- tcExpr p e
   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
+  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