Commit 2ca9420d authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

Removed record extensions

parent c7db669b
......@@ -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
......
......@@ -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))
......
......@@ -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
......
......@@ -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.
......
......@@ -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 ++ ")"
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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