Removed record extensions

2ca9420d · Jan Rasmus Tikovsky · c7db669b · 2ca9420d · 2ca9420d · 2ca9420d
Commit 2ca9420d authored Oct 21, 2014 by Jan Rasmus Tikovsky
21 changed files
--- a/src/Base/CurryTypes.hs
+++ b/src/Base/CurryTypes.hs
@@ -67,15 +67,10 @@ toType' tvs (CS.ListType            ty)
  = TypeConstructor (qualify listId) [toType' tvs ty]
 toType' tvs (CS.ArrowType      ty1 ty2)
  = TypeArrow (toType' tvs ty1) (toType' tvs ty2)
-toType' tvs (CS.RecordType      fs rty)
-  = TypeRecord fs' rty'
+toType' tvs (CS.RecordType          fs)
+  = TypeRecord fs'
  where
    fs'  = concatMap (\ (ls, ty) -> map (\ l -> (l, toType' tvs ty)) ls) fs
-    rty' = case rty of
-      Nothing -> Nothing
-      Just ty -> case toType' tvs ty of
-        TypeVariable tv -> Just tv
-        _ -> internalError $ "Base.CurryTypes.toType' " ++ show ty

 fromQualType :: ModuleIdent -> Type -> CS.TypeExpr
 fromQualType m = fromType . unqualifyType m
@@ -95,9 +90,8 @@ fromType (TypeArrow     ty1 ty2)   =
  CS.ArrowType (fromType ty1) (fromType ty2)
 fromType (TypeSkolem          k)   =
  CS.VariableType $ mkIdent $ "_?" ++ show k
-fromType (TypeRecord     fs rty)   = CS.RecordType
+fromType (TypeRecord         fs)   = CS.RecordType
  (map (\ (l, ty) -> ([l], fromType ty)) fs)
-  ((fromType . TypeVariable) `fmap` rty)

 -- The following functions implement pretty-printing for types.
 ppType :: ModuleIdent -> Type -> Doc

--- a/src/Base/Expr.hs
+++ b/src/Base/Expr.hs
@@ -180,7 +180,7 @@ instance Expr TypeExpr where
  fv (TupleType         tys) = fv tys
  fv (ListType           ty) = fv ty
  fv (ArrowType     ty1 ty2) = fv ty1 ++ fv ty2
-  fv (RecordType     fs rty) = maybe [] fv rty ++ fv (map snd fs)
+  fv (RecordType         fs) = fv (map snd fs)

 filterBv :: QuantExpr e => e -> [Ident] -> [Ident]
 filterBv e = filter (`Set.notMember` Set.fromList (bv e))

--- a/src/Base/TypeSubst.hs
+++ b/src/Base/TypeSubst.hs
@@ -45,11 +45,7 @@ instance SubstType Type where
  subst sigma (TypeArrow      ty1 ty2) =
    TypeArrow (subst sigma ty1) (subst sigma ty2)
  subst _     ts@(TypeSkolem        _) = ts
-  subst sigma (TypeRecord       fs rv) = case rv of
-    Nothing -> TypeRecord fs' Nothing
-    Just r' -> case substVar sigma r' of
-      TypeVariable tv -> TypeRecord fs' (Just tv)
-      ty              -> ty
+  subst sigma (TypeRecord          fs) = TypeRecord fs'
   where fs' = map (\ (l,ty) -> (l, subst sigma ty)) fs

 instance SubstType TypeScheme where
@@ -87,10 +83,7 @@ expandAliasType _   (TypeConstrained   tys n) = TypeConstrained tys n
 expandAliasType tys (TypeArrow       ty1 ty2) =
  TypeArrow (expandAliasType tys ty1) (expandAliasType tys ty2)
 expandAliasType _   tsk@(TypeSkolem        _) = tsk
-expandAliasType tys (TypeRecord        fs rv) = case rv of
-  Nothing -> TypeRecord fs' Nothing
-  Just r' -> let (TypeVariable tv) = expandAliasType tys $ TypeVariable r'
-             in  TypeRecord fs' (Just tv)
+expandAliasType tys (TypeRecord           fs) = TypeRecord fs'
 where fs' = map (\ (l, ty) -> (l, expandAliasType tys ty)) fs

 normalize :: Type -> Type

--- a/src/Base/Types.hs
+++ b/src/Base/Types.hs
@@ -57,7 +57,7 @@ data Type
  | TypeArrow Type Type
  | TypeConstrained [Type] Int
  | TypeSkolem Int
-  | TypeRecord [(Ident, Type)] (Maybe Int)
+  | TypeRecord [(Ident, Type)]
  deriving (Eq, Show)

 -- The function 'isArrowType' checks whether a type is a function
@@ -93,8 +93,7 @@ typeVars ty = vars ty [] where
  vars (TypeConstrained   _ _) tvs = tvs
  vars (TypeArrow     ty1 ty2) tvs = vars ty1 (vars ty2 tvs)
  vars (TypeSkolem          _) tvs = tvs
-  vars (TypeRecord     fs rtv) tvs =
-    foldr vars (maybe tvs (:tvs) rtv) (map snd fs)
+  vars (TypeRecord         fs) tvs = foldr vars tvs (map snd fs)

 typeConstrs :: Type -> [QualIdent]
 typeConstrs ty = constrs ty [] where
@@ -103,7 +102,7 @@ typeConstrs ty = constrs ty [] where
  constrs (TypeConstrained    _ _) tcs = tcs
  constrs (TypeArrow      ty1 ty2) tcs = constrs ty1 (constrs ty2 tcs)
  constrs (TypeSkolem           _) tcs = tcs
-  constrs (TypeRecord        fs _) tcs = foldr constrs tcs (map snd fs)
+  constrs (TypeRecord          fs) tcs = foldr constrs tcs (map snd fs)

 typeSkolems :: Type -> [Int]
 typeSkolems ty = skolems ty [] where
@@ -112,7 +111,7 @@ typeSkolems ty = skolems ty [] where
  skolems (TypeConstrained   _ _) sks = sks
  skolems (TypeArrow     ty1 ty2) sks = skolems ty1 (skolems ty2 sks)
  skolems (TypeSkolem          k) sks = k : sks
-  skolems (TypeRecord       fs _) sks = foldr skolems sks (map snd fs)
+  skolems (TypeRecord         fs) sks = foldr skolems sks (map snd fs)

 -- The function 'equTypes' computes whether two types are equal modulo
 -- renaming of type variables.
@@ -135,14 +134,10 @@ equTypes t1 t2 = fst (equ [] t1 t2)
     in  (res1 && res2, is2)
 equ is (TypeSkolem            i1) (TypeSkolem            i2)
  = equVar is i1 i2
- equ is (TypeRecord fs1 (Just r1)) (TypeRecord fs2 (Just r2))
-   = let (res1, is1) = equVar     is  r1  r2
-         (res2, is2) = equRecords is1 fs1 fs2
-     in  (res1 && res2, is2)
- equ is (TypeRecord fs1   Nothing) (TypeRecord fs2   Nothing)
-   = equRecords is fs1 fs2
- equ is _                         _
-   = (False, is)
+ equ is (TypeRecord fs1)           (TypeRecord fs2)
+  = equRecords is fs1 fs2
+ equ is _                          _
+  = (False, is)

 equVar is i1 i2 = case lookup i1 is of
   Nothing  -> (True, (i1, i2) : is)
@@ -182,8 +177,8 @@ qualifyType m (TypeConstrained tys tv) =
 qualifyType m (TypeArrow      ty1 ty2) =
  TypeArrow (qualifyType m ty1) (qualifyType m ty2)
 qualifyType _ skol@(TypeSkolem      _) = skol
-qualifyType m (TypeRecord      fs rty) =
-  TypeRecord (map (\ (l, ty) -> (l, qualifyType m ty)) fs) rty
+qualifyType m (TypeRecord          fs) =
+  TypeRecord (map (\ (l, ty) -> (l, qualifyType m ty)) fs)

 unqualifyType :: ModuleIdent -> Type -> Type
 unqualifyType m (TypeConstructor tc tys) =
@@ -194,8 +189,8 @@ unqualifyType m (TypeConstrained tys tv) =
 unqualifyType m (TypeArrow      ty1 ty2) =
  TypeArrow (unqualifyType m ty1) (unqualifyType m ty2)
 unqualifyType _ skol@(TypeSkolem      _) = skol
-unqualifyType m (TypeRecord      fs rty) =
-  TypeRecord (map (\ (l, ty) -> (l, unqualifyType m ty)) fs) rty
+unqualifyType m (TypeRecord          fs) =
+  TypeRecord (map (\ (l, ty) -> (l, unqualifyType m ty)) fs)

 -- The type 'DataConstr' is used to represent value constructors introduced
 -- by data or newtype declarations.

--- a/src/Base/Typing.hs
+++ b/src/Base/Typing.hs
@@ -197,8 +197,8 @@ argType (InfixFuncPattern t1 op t2) = argType (FunctionPattern op [t1,t2])
 argType (RecordPattern fs _) = do
  recInfo <- getFieldIdent fs >>= getRecordInfo
  case recInfo of
-    [AliasType qi n rty@(TypeRecord _ _)] -> do
-      (TypeRecord fts' _, tys) <- instType' n rty
+    [AliasType qi n rty@(TypeRecord _)] -> do
+      (TypeRecord fts', tys) <- instType' n rty
      fts   <- mapM fieldPattType fs
      theta <- getTypeSubst
      let theta' = foldr (unifyTypedLabels fts') theta fts
@@ -273,8 +273,8 @@ exprType (Case _ _ _ alts) = freshTypeVar >>= flip altType alts
 exprType (RecordConstr fs) = do
  recInfo <- getFieldIdent fs >>= getRecordInfo
  case recInfo of
-    [AliasType qi n rty@(TypeRecord _ _)] -> do
-      (TypeRecord fts' _, tys) <- instType' n rty
+    [AliasType qi n rty@(TypeRecord _)] -> do
+      (TypeRecord fts', tys) <- instType' n rty
      fts   <- mapM fieldExprType fs
      theta <- getTypeSubst
      let theta' = foldr (unifyTypedLabels fts') theta fts
@@ -285,8 +285,8 @@ exprType (RecordConstr fs) = do
 exprType (RecordSelection e l) = do
  recInfo <- getRecordInfo l
  case recInfo of
-    [AliasType qi n rty@(TypeRecord _ _)] -> do
-      (TypeRecord fts _, tys) <- instType' n rty
+    [AliasType qi n rty@(TypeRecord _)] -> do
+      (TypeRecord fts, tys) <- instType' n rty
      ety <- exprType e
      let rtc = TypeConstructor qi tys
      case lookup l fts of
@@ -300,8 +300,8 @@ exprType (RecordSelection e l) = do
 exprType (RecordUpdate fs e) = do
  recInfo <- getFieldIdent fs >>= getRecordInfo
  case recInfo of
-    [AliasType qi n rty@(TypeRecord _ _)] -> do
-      (TypeRecord fts' _, tys) <- instType' n rty
+    [AliasType qi n rty@(TypeRecord _)] -> do
+      (TypeRecord fts', tys) <- instType' n rty
      -- Type check field updates
      fts <- mapM fieldExprType fs
      modifyTypeSubst (\s -> foldr (unifyTypedLabels fts') s fts)
@@ -402,7 +402,7 @@ unifyTypes (TypeArrow ty11 ty12) (TypeArrow ty21 ty22) theta =
  unifyTypes ty11 ty21 (unifyTypes ty12 ty22 theta)
 unifyTypes (TypeSkolem k1) (TypeSkolem k2) theta
  | k1 == k2 = theta
-unifyTypes (TypeRecord fs1 Nothing) (TypeRecord fs2 Nothing) theta
+unifyTypes (TypeRecord fs1) (TypeRecord fs2) theta
  | length fs1 == length fs2 = foldr (unifyTypedLabels fs1) theta fs2
 unifyTypes ty1 ty2 _ = internalError $
  "Base.Typing.unify: (" ++ show ty1 ++ ") (" ++ show ty2 ++ ")"

--- a/src/Checks/ExportCheck.hs
+++ b/src/Checks/ExportCheck.hs
@@ -224,8 +224,8 @@ constrs (RenamingType _ _ (DataConstr c _ _)) = [c]
 constrs (AliasType _ _ _)  = []

 labels :: TypeInfo -> [Ident]
-labels (AliasType _ _ (TypeRecord fs _)) = map fst fs
-labels _                                 = []
+labels (AliasType _ _ (TypeRecord fs)) = map fst fs
+labels _                               = []

 isDataType :: TypeInfo -> Bool
 isDataType (DataType     _ _ _) = True
@@ -233,8 +233,8 @@ isDataType (RenamingType _ _ _) = True
 isDataType (AliasType    _ _ _) = False

 isRecordType :: TypeInfo -> Bool
-isRecordType (AliasType _ _ (TypeRecord _ _)) = True
-isRecordType _                                = False
+isRecordType (AliasType _ _ (TypeRecord _)) = True
+isRecordType _                              = False

 -- ---------------------------------------------------------------------------
 -- Error messages

--- a/src/Checks/InterfaceCheck.hs
+++ b/src/Checks/InterfaceCheck.hs
@@ -106,7 +106,7 @@ checkImport (HidingDataDecl p tc tvs)
          | tc == tc' && length tvs == n' = Just ok
        check (RenamingType tc' n' _)
          | tc == tc' && length tvs == n' = Just ok
-        check (AliasType tc' n' (TypeRecord _ _))
+        check (AliasType tc' n' (TypeRecord _))
          | tc == tc' && length tvs == n' = Just ok
        check _                           = Nothing
 checkImport (IDataDecl p tc tvs cs) = checkTypeInfo "data type" check p tc

--- a/src/Checks/InterfaceSyntaxCheck.hs
+++ b/src/Checks/InterfaceSyntaxCheck.hs
@@ -79,7 +79,7 @@ bindType (INewtypeDecl   _ tc _ nc) = qualBindTopEnv "" tc (Data tc [nconstr nc]
 -- jrt 2014-10-16: record types are handled like data declarations; this is
 -- necessary because type constructors of record types are not expanded anymore
 -- and can occur in interfaces
-bindType (ITypeDecl _ tc _ (RecordType _ _)) = qualBindTopEnv "" tc (Data tc [])
+bindType (ITypeDecl _ tc _ (RecordType _)) = qualBindTopEnv "" tc (Data tc [])
 bindType (ITypeDecl       _ tc _ _) = qualBindTopEnv "" tc (Alias tc)
 bindType (IFunctionDecl    _ _ _ _) = id

@@ -141,8 +141,7 @@ checkType (VariableType        tv) = checkType (ConstructorType (qualify tv) [])
 checkType (TupleType          tys) = liftM TupleType (mapM checkType tys)
 checkType (ListType            ty) = liftM ListType (checkType ty)
 checkType (ArrowType      ty1 ty2) = liftM2 ArrowType (checkType ty1) (checkType ty2)
-checkType (RecordType      fs mty) = liftM2 RecordType (mapM checkField fs)
-                                            (liftMaybe checkType mty)
+checkType (RecordType          fs) = liftM RecordType (mapM checkField fs)
 where checkField (l, ty) = checkType ty >>= \ty' -> return (l, ty')

 checkTypeConstructor :: QualIdent -> [TypeExpr] -> ISC TypeExpr

--- a/src/Checks/KindCheck.hs
+++ b/src/Checks/KindCheck.hs
@@ -258,14 +258,11 @@ checkType (TupleType     tys) = TupleType `liftM` mapM checkType tys
 checkType (ListType       ty) = ListType  `liftM` checkType ty
 checkType (ArrowType ty1 ty2) =
  liftM2 ArrowType (checkType ty1) (checkType ty2)
-checkType (RecordType   fs r) = do
+checkType (RecordType     fs) = do
  fs' <- forM fs $ \ (l, ty) -> do
    ty' <- checkType ty
    return (l, ty')
-  r'  <- case r of
-    Nothing -> return Nothing
-    Just ar -> Just `liftM` checkType ar
-  return $ RecordType fs' r'
+  return $ RecordType fs'

 checkClosed :: [Ident] -> TypeExpr -> KCM TypeExpr
 checkClosed tvs (ConstructorType tc tys) =
@@ -279,14 +276,11 @@ checkClosed tvs (ListType       ty) =
  ListType `liftM` checkClosed tvs ty
 checkClosed tvs (ArrowType ty1 ty2) =
  liftM2 ArrowType (checkClosed tvs ty1) (checkClosed tvs ty2)
-checkClosed tvs (RecordType   fs r) = do
+checkClosed tvs (RecordType     fs) = do
  fs' <- forM fs $ \ (l, ty) -> do
    ty' <- checkClosed tvs ty
    return (l, ty')
-  r'  <- case r of
-    Nothing -> return Nothing
-    Just ar -> Just `liftM` checkClosed tvs ar
-  return $ RecordType fs' r'
+  return $ RecordType fs'

 -- ---------------------------------------------------------------------------
 -- Auxiliary definitions

--- a/src/Checks/SyntaxCheck.hs
+++ b/src/Checks/SyntaxCheck.hs
@@ -206,7 +206,7 @@ renameInfo _     (DataConstructor    qid a _) = Constr    qid a
 renameInfo _     (NewtypeConstructor qid   _) = Constr    qid 1
 renameInfo _     (Value              qid a _) = GlobalVar qid a
 renameInfo tcEnv (Label              _   r _) = case qualLookupTC r tcEnv of
-  [AliasType _ _ (TypeRecord fs _)] -> RecordLabel r $ map fst fs
+  [AliasType _ _ (TypeRecord fs)] -> RecordLabel r $ map fst fs
  _ -> internalError $ "SyntaxCheck.renameInfo: ambiguous record " ++ show r

 bindGlobal :: ModuleIdent -> Ident -> RenameInfo -> RenameEnv -> RenameEnv
@@ -221,7 +221,7 @@ bindLocal = bindNestEnv
 bindTypeDecl :: Decl -> SCM ()
 bindTypeDecl (DataDecl    _ _ _ cs) = mapM_ bindConstr cs
 bindTypeDecl (NewtypeDecl _ _ _ nc) = bindNewConstr nc
-bindTypeDecl (TypeDecl _ t _ (RecordType fs _)) = do
+bindTypeDecl (TypeDecl _ t _ (RecordType fs)) = do
  m <- getModuleIdent
  others <- qualLookupVar (qualifyWith m t) `liftM` getRenameEnv
  when (any isConstr others) $ report $ errIllegalRecordId t
@@ -332,10 +332,8 @@ checkExtension (KnownExtension   _ e) = enableExtension e
 checkExtension (UnknownExtension p e) = report $ errUnknownExtension p e

 checkTypeDecl :: Decl -> SCM Decl
-checkTypeDecl rec@(TypeDecl _ r _ (RecordType fs rty)) = do
+checkTypeDecl rec@(TypeDecl _ r _ (RecordType fs)) = do
  checkRecordExtension $ idPosition r
-  when (isJust  rty) $ internalError
-                       "SyntaxCheck.checkTypeDecl: illegal record type"
  when (null     fs) $ report $ errEmptyRecord $ idPosition r
  return rec
 checkTypeDecl d = return d

--- a/src/Checks/TypeCheck.hs
+++ b/src/Checks/TypeCheck.hs
@@ -31,7 +31,7 @@ import qualified Control.Monad.State as S   (State, execState, gets, modify)
 import           Data.List                  (nub, partition)
 import qualified Data.Map            as Map (Map, delete, empty, insert, lookup)
 import           Data.Maybe
-  (catMaybes, fromMaybe, listToMaybe, maybeToList)
+  (catMaybes, fromMaybe)
 import qualified Data.Set            as Set
  (Set, fromList, member, notMember, unions)

@@ -205,8 +205,7 @@ ft _ (VariableType         _) tcs = tcs
 ft m (TupleType          tys) tcs = foldr (ft m) tcs tys
 ft m (ListType            ty) tcs = ft m ty tcs
 ft m (ArrowType      ty1 ty2) tcs = ft m ty1 $ ft m ty2 $ tcs
-ft m (RecordType      fs rty) tcs =
-  foldr (ft m) (maybe tcs (\ty -> ft m ty tcs) rty) (map snd fs)
+ft m (RecordType          fs) tcs = foldr (ft m) tcs (map snd fs)

 -- The type constructor environment 'tcEnv' maintains all types
 -- in fully expanded form (except for record types).
@@ -282,7 +281,7 @@ bindLabels' :: TCEnv -> ValueEnv -> ValueEnv
 bindLabels' tcEnv tyEnv = foldr (bindFieldLabels . snd) tyEnv
                        $ localBindings tcEnv
  where
-  bindFieldLabels (AliasType r _ (TypeRecord fs _)) env =
+  bindFieldLabels (AliasType r _ (TypeRecord fs)) env =
    foldr (bindField r) env fs
  bindFieldLabels _ env = env

@@ -341,11 +340,10 @@ nameType (ListType ty) tvs = (ListType ty', tvs')
 nameType (ArrowType ty1 ty2) tvs = (ArrowType ty1' ty2', tvs'')
  where (ty1', tvs' ) = nameType ty1 tvs
        (ty2', tvs'') = nameType ty2 tvs'
-nameType (RecordType fs rty) tvs =
-  (RecordType (zip ls tys') (listToMaybe rty'), tvs)
+nameType (RecordType     fs) tvs =
+  (RecordType (zip ls tys'), tvs)
  where (ls  , tys) = unzip fs
        (tys', _  ) = nameTypes tys tvs
-        (rty', _  ) = nameTypes (maybeToList rty) tvs
 nameType (VariableType _) [] = internalError
 "TypeCheck.nameType: empty ident list"

@@ -624,8 +622,8 @@ tcPattern p (InfixFuncPattern t1 op 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)
+    [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
@@ -717,8 +715,8 @@ tcPatternFP p (InfixFuncPattern t1 op 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)
+    [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
@@ -935,8 +933,8 @@ tcExpr p (Case _ _ e alts) = do
 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)
+    [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
@@ -946,9 +944,9 @@ tcExpr p r@(RecordConstr fs) = do
 tcExpr p r@(RecordSelection e l) = do
  recInfo <- getRecordInfo l
  case recInfo of
-    [AliasType qi n rty@(TypeRecord _ _)] -> do
+    [AliasType qi n rty@(TypeRecord _)] -> do
      ety <- tcExpr p e
-      (TypeRecord fts _, tys) <- inst' (ForAll n rty)
+      (TypeRecord fts, tys) <- inst' (ForAll n rty)
      let rtc = TypeConstructor qi tys
      case lookup l fts of
        Just lty -> do
@@ -961,8 +959,8 @@ tcExpr p r@(RecordSelection e l) = do
 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)
+    [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
@@ -1080,7 +1078,7 @@ unifyTypes m (TypeArrow ty11 ty12) (TypeArrow ty21 ty22) =
  unifyTypeLists m [ty11, ty12] [ty21, ty22]
 unifyTypes _ (TypeSkolem k1) (TypeSkolem k2)
  | k1 == k2 = Right idSubst
-unifyTypes m (TypeRecord fs1 Nothing) tr2@(TypeRecord fs2 Nothing)
+unifyTypes m (TypeRecord fs1) tr2@(TypeRecord fs2)
  | length fs1 == length fs2 = unifyTypedLabels m fs1 tr2
 unifyTypes m ty1 ty2 = Left (errIncompatibleTypes m ty1 ty2)

@@ -1137,8 +1135,8 @@ unifyLabel p what doc fs rty (l, ty) = case lookup l fs of

 unifyTypedLabels :: ModuleIdent -> [(Ident,Type)] -> Type
                 -> Either Doc TypeSubst
-unifyTypedLabels _ []           (TypeRecord _ _)      = Right idSubst
-unifyTypedLabels m ((l,ty):fs1) tr@(TypeRecord fs2 _) =
+unifyTypedLabels _ []           (TypeRecord _)      = Right idSubst
+unifyTypedLabels m ((l,ty):fs1) tr@(TypeRecord fs2) =
  either Left
         (\r ->
           maybe (Left (errMissingLabel m l tr))
@@ -1288,12 +1286,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
@@ -1302,8 +1300,8 @@ expandType _ _     tc@(TypeConstrained _ _) = tc
 expandType m tcEnv (TypeArrow      ty1 ty2) =
  TypeArrow (expandType m tcEnv ty1) (expandType m tcEnv ty2)
 expandType _ _     ts@(TypeSkolem        _) = ts
-expandType m tcEnv (TypeRecord       fs rv) =
-  TypeRecord (map (\ (l, ty) -> (l, expandType m tcEnv ty)) fs) rv
+expandType m tcEnv (TypeRecord          fs) =
+  TypeRecord (map (\ (l, ty) -> (l, expandType m tcEnv ty)) fs)

 -- The functions 'fvEnv' and 'fsEnv' compute the set of free type variables
 -- and free skolems of a type environment, respectively. We ignore the types

--- a/src/Checks/WarnCheck.hs
+++ b/src/Checks/WarnCheck.hs
@@ -253,9 +253,7 @@ checkTypeExpr (VariableType          v) = visitTypeId v
 checkTypeExpr (TupleType           tys) = mapM_ checkTypeExpr tys
 checkTypeExpr (ListType             ty) = checkTypeExpr ty
 checkTypeExpr (ArrowType       ty1 ty2) = mapM_ checkTypeExpr [ty1, ty2]
-checkTypeExpr (RecordType       fs rty) = do
-  mapM_ checkTypeExpr (map snd fs)
-  maybe ok checkTypeExpr rty
+checkTypeExpr (RecordType           fs) = mapM_ checkTypeExpr (map snd fs)

 -- Checks locally declared identifiers (i.e. functions and logic variables)
 -- for shadowing
@@ -549,8 +547,8 @@ getAllLabels l = do
    [Label _ r _] -> do
      tcEnv <- gets tyConsEnv
      case qualLookupTC r tcEnv of
-        [AliasType _ _ (TypeRecord fs _)] -> return (r, map fst fs)
-        _                                 -> internalError $
+        [AliasType _ _ (TypeRecord fs)] -> return (r, map fst fs)
+        _                               -> internalError $
          "Checks.WarnCheck.getAllLabels: " ++ show r
    _             -> internalError $ "Checks.WarnCheck.getAllLabels: " ++ show l

@@ -717,7 +715,7 @@ getTyCons _ (TypeConstructor tc _) = do
      [RenamingType _ _ nc] -> [nc]
      err                   -> internalError $ "Checks.WarnCheck.getTyCons: "
                            ++ show tc ++ ' ' : show err ++ '\n' : show tcEnv
-getTyCons q (TypeRecord fs _) = return [DataConstr (unqualify q) (length fs) (map snd fs)]
+getTyCons q (TypeRecord fs) = return [DataConstr (unqualify q) (length fs) (map snd fs)]
 getTyCons _ _ = internalError "Checks.WarnCheck.getTyCons"

 -- |Resugar the exhaustive patterns previously desugared at 'simplifyPat'.
@@ -739,9 +737,9 @@ tidyPat p@(ConstructorPattern c ps)
  | otherwise                       = do
    ty <- getConTy c
    case ty of
-      TypeRecord fs _ -> flip RecordPattern Nothing `liftM`
-                         zipWithM mkFieldPat fs ps
-      _               -> return p
+      TypeRecord fs -> flip RecordPattern Nothing `liftM`
+                       zipWithM mkFieldPat fs ps
+      _             -> return p
  where
  isFiniteList (ConstructorPattern d []     )                = d == qNilId
  isFiniteList (ConstructorPattern d [_, e2]) | d == qConsId = isFiniteList e2
@@ -908,9 +906,9 @@ insertTypeExpr (ConstructorType _ tys) = mapM_ insertTypeExpr tys
 insertTypeExpr (TupleType         tys) = mapM_ insertTypeExpr tys
 insertTypeExpr (ListType           ty) = insertTypeExpr ty
 insertTypeExpr (ArrowType     ty1 ty2) = mapM_ insertTypeExpr [ty1,ty2]
-insertTypeExpr (RecordType      _ rty) = do
+insertTypeExpr (RecordType          _) = ok
  --mapM_ insertVar (concatMap fst fs)
-  maybe (return ()) insertTypeExpr rty
+  --maybe (return ()) insertTypeExpr rty

 insertConstrDecl :: ConstrDecl -> WCM ()
 insertConstrDecl (ConstrDecl _ _    c _) = insertConsId c

--- a/src/Exports.hs
+++ b/src/Exports.hs
@@ -91,8 +91,8 @@ typeDecl m tcEnv (ExportTypeWith tc cs) ds = case qualLookupTC tc tcEnv of
    where tvs = take n' (drop n identSupply)
          ty' = fromQualType m ty
  [AliasType tc' n ty] -> case ty of
-    TypeRecord fs _ ->
-        let ty' = TypeRecord (filter (\ (l,_) -> elem l cs) fs) Nothing
+    TypeRecord fs ->
+        let ty' = TypeRecord (filter (\ (l,_) -> elem l cs) fs)
        in  iTypeDecl ITypeDecl m tc' n (fromQualType m ty') : ds
    _ -> iTypeDecl ITypeDecl m tc' n (fromQualType m ty) : ds
  _ -> internalError "Exports.typeDecl"
@@ -168,8 +168,7 @@ identsType (VariableType         _) xs = xs
 identsType (TupleType          tys) xs = foldr identsType xs tys
 identsType (ListType            ty) xs = identsType ty xs
 identsType (ArrowType      ty1 ty2) xs = identsType ty1 (identsType ty2 xs)
-identsType (RecordType      fs rty) xs =
-  foldr identsType (maybe xs (\ty -> identsType ty xs) rty) (map snd fs)
+identsType (RecordType          fs) xs = foldr identsType xs (map snd fs)

 -- After the interface declarations have been computed, the compiler
 -- eventually must add hidden (data) type declarations to the interface
@@ -220,8 +219,8 @@ usedTypesType (TupleType          tys) tcs = foldr usedTypesType tcs tys
 usedTypesType (ListType            ty) tcs = usedTypesType ty tcs
 usedTypesType (ArrowType      ty1 ty2) tcs =
  usedTypesType ty1 (usedTypesType ty2 tcs)
-usedTypesType (RecordType      fs rty) tcs = foldr usedTypesType
-  (maybe tcs (\ty -> usedTypesType ty tcs) rty) (map snd fs)
+usedTypesType (RecordType          fs) tcs = foldr usedTypesType
+  tcs (map snd fs)

 definedTypes :: [IDecl] -> [QualIdent]
 definedTypes ds = foldr definedType [] ds

--- a/src/Generators/GenAbstractCurry.hs
+++ b/src/Generators/GenAbstractCurry.hs
@@ -192,16 +192,7 @@ genTypeExpr env (ListType       ty)
 genTypeExpr env (ArrowType ty1 ty2) = (env2, CFuncType ty1' ty2')
  where (env1, ty1') = genTypeExpr env  ty1
        (env2, ty2') = genTypeExpr env1 ty2
-genTypeExpr env (RecordType fss mr) = case mr of
-  Nothing -> (env1, CRecordType (zip ls' ts') Nothing)
-  Just tvar@(VariableType _) ->
-    let (env2, CTVar iname) = genTypeExpr env1 tvar
-    in  (env2, CRecordType (zip ls' ts') (Just iname))
-  Just r@(RecordType _ _) ->
-    let (env2, CRecordType fields rbase) = genTypeExpr env1 r
-        fields' = foldr (uncurry insertEntry) fields (zip ls' ts')
-    in  (env2, CRecordType fields' rbase)
-  _ -> internalError "GenAbstractCurry.gegnTypeExpr: illegal record base"
+genTypeExpr env (RecordType    fss) = (env1, CRecordType (zip ls' ts'))
  where
  (ls  , ts ) = unzip $ concatMap (\ (ls1,ty) -> map (\l -> (l,ty)) ls1) fss
  (env1, ts') = mapAccumL genTypeExpr env ts
@@ -284,7 +275,7 @@ genFuncDecl isLocal env (ident, decls)
  compArityFromType (CTVar         _) = 0
  compArityFromType (CFuncType  _ t2) = 1 + compArityFromType t2
  compArityFromType (CTCons      _ _) = 0
-  compArityFromType (CRecordType _ _) =
+  compArityFromType (CRecordType   _) =
    internalError "GenAbstractCurry.genFuncDecl.compArityFromType: record type"

  compRule _  [] Nothing  = internalError $ "GenAbstractCurry.compRule: "
@@ -912,11 +903,11 @@ simplifyRhsLocals (GuardedRhs  _ locals) = locals

 -- Insert a value under a key into an association list. If the list
 -- already contains a value for that key, the old value is replaced.
-insertEntry :: Eq a => a -> b -> [(a, b)] -> [(a, b)]
-insertEntry k v []             = [(k, v)]
-insertEntry k v ((l, w) : kvs)
-  | k == l    = (k, v) : kvs
-  | otherwise = (l, w) : insertEntry k v kvs
+-- insertEntry :: Eq a => a -> b -> [(a, b)] -> [(a, b)]
+-- insertEntry k v []             = [(k, v)]
+-- insertEntry k v ((l, w) : kvs)
+--   | k == l    = (k, v) : kvs
+--   | otherwise = (l, w) : insertEntry k v kvs

 -- Return 'True' iff a list is a singleton list (contains exactly one element)
 isSingleton :: [a] -> Bool

--- a/src/Generators/GenFlatCurry.hs
+++ b/src/Generators/GenFlatCurry.hs
@@ -659,7 +659,7 @@ genRecordTypes = records >>= mapM genRecordType

 --
 genRecordType :: CS.IDecl -> FlatState TypeDecl
-genRecordType (CS.ITypeDecl _ qid params (CS.RecordType fs _)) = do
+genRecordType (CS.ITypeDecl _ qid params (CS.RecordType fs)) = do