diff --git a/CHANGELOG.md b/CHANGELOG.md index 4e169963777cbec5d4ac881b8bf44e61bb423524..3f04374c7e23ab32d2a1b6dd11d10bc16e733a93 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,8 @@ 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 diff --git a/src/Checks/TypeCheck.hs b/src/Checks/TypeCheck.hs index c92e3b00f37da7311b2d1e78732d904849ed5c68..7007ebffcfb9344fd5ef7c206442aee25457a4d5 100644 --- a/src/Checks/TypeCheck.hs +++ b/src/Checks/TypeCheck.hs @@ -25,12 +25,15 @@ module Checks.TypeCheck (typeCheck) where -import Control.Monad (liftM, liftM2, liftM3, replicateM, unless) -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, fromJust, fromMaybe, isJust, listToMaybe, maybeToList) -import qualified Data.Set as Set (Set, fromList, member, notMember, unions) +import Control.Monad + (liftM, liftM2, liftM3, replicateM, unless) +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) +import qualified Data.Set as Set + (Set, fromList, member, notMember, unions) import Curry.Base.Ident import Curry.Base.Position @@ -47,8 +50,7 @@ import Base.Types import Base.TypeSubst import Base.Utils (foldr2) -import Env.TypeConstructor (TCEnv, TypeInfo (..), bindTypeInfo - , qualLookupTC) +import Env.TypeConstructor (TCEnv, TypeInfo (..), bindTypeInfo, qualLookupTC) import Env.Value ( ValueEnv, ValueInfo (..), bindFun, rebindFun , bindGlobalInfo, bindLabel, lookupValue, qualLookupValue ) @@ -76,7 +78,7 @@ typeCheck m tcEnv tyEnv decls = execTCM check initState bindLabels tcDecls vds (tds, vds) = partition isTypeDecl decls - initState = TcState m tcEnv tyEnv tcEnv idSubst emptySigEnv 0 [] + initState = TcState m tcEnv tyEnv idSubst emptySigEnv 0 [] -- The type checker makes use of a state monad in order to maintain the type -- environment, the current substitution, and a counter which is used for @@ -86,7 +88,6 @@ data TcState = TcState { moduleIdent :: ModuleIdent -- read only , tyConsEnv :: TCEnv , valueEnv :: ValueEnv - , recordEnv :: TCEnv , typeSubst :: TypeSubst , sigEnv :: SigEnv , nextId :: Int -- automatic counter @@ -110,12 +111,6 @@ getValueEnv = S.gets valueEnv modifyValueEnv :: (ValueEnv -> ValueEnv) -> TCM () modifyValueEnv f = S.modify $ \ s -> s { valueEnv = f $ valueEnv s } -getRecordEnv :: TCM TCEnv -getRecordEnv = S.gets recordEnv - -setRecordEnv :: TCEnv -> TCM () -setRecordEnv recEnv = S.modify $ \ s -> s { recordEnv = recEnv } - getTypeSubst :: TCM TypeSubst getTypeSubst = S.gets typeSubst @@ -144,7 +139,7 @@ pre &&> suf = do execTCM :: TCM a -> TcState -> (TCEnv, ValueEnv, [Message]) execTCM tcm s = let s' = S.execState tcm s - in ( recordEnv s' + in ( tyConsEnv s' , typeSubst s' `subst` valueEnv s' , reverse $ errors s' ) @@ -153,15 +148,12 @@ execTCM tcm s = let s' = S.execState tcm s -- Before type checking starts, the types defined in the local module -- have to be entered into the type constructor environment. All type -- synonyms occurring in the definitions are fully expanded (except for --- record types. For each record type a new type constructor is introduced --- in the type constructor environment. The expanded record types are stored --- in the record environment which is used during type checking) and all type --- constructors are qualified with the name of the module in which they --- are defined. This is possible because Curry does not allow (mutually) --- recursive type synonyms. In order to simplify the expansion of type --- synonyms, the compiler first performs a dependency analysis on the --- type definitions. This also makes it easy to identify (mutually) --- recursive synonyms. +-- record types) and all type constructors are qualified with the name +-- of the module in which they are defined. This is possible because +-- Curry does not allow (mutually) recursive type synonyms. +-- In order to simplify the expansion of type synonyms, the compiler +-- first performs a dependency analysis on the type definitions. +-- This also makes it easy to identify (mutually) recursive synonyms. -- Note that 'bindTC' is passed the final type constructor environment in -- order to handle the expansion of type synonyms. This does not lead to a @@ -193,11 +185,16 @@ checkTypeDecls _ [] = internalError "TypeCheck.checkTypeDecls: empty list" checkTypeDecls _ [DataDecl _ _ _ _] = return () checkTypeDecls _ [NewtypeDecl _ _ _ _] = return () -checkTypeDecls m [TypeDecl _ tc _ ty] +checkTypeDecls m [t@(TypeDecl _ tc _ ty)] + -- allow recursive record declarations + | isRecordDecl t = return () | tc `elem` ft m ty [] = report $ errRecursiveTypes [tc] | otherwise = return () -checkTypeDecls _ (TypeDecl _ tc _ _ : ds) = - report $ errRecursiveTypes $ tc : [tc' | TypeDecl _ tc' _ _ <- ds] +checkTypeDecls _ (t@(TypeDecl _ tc _ _) : ds) + -- allow mutually recursive record declarations + | isRecordDecl t || any isRecordDecl ds = return () + | otherwise = + report $ errRecursiveTypes $ tc : [tc' | TypeDecl _ tc' _ _ <- ds] checkTypeDecls _ _ = internalError "TypeCheck.checkTypeDecls: no type synonym" @@ -213,40 +210,27 @@ ft m (RecordType fs rty) tcs = -- The type constructor environment 'tcEnv' maintains all types -- in fully expanded form (except for record types). --- The record environment 'recEnv' maintains all types --- in fully expanded form (even the record types). bindTypes :: [Decl] -> TCM () bindTypes ds = do m <- getModuleIdent tcEnv <- getTyConsEnv - recEnv <- getRecordEnv - let tcEnv' = foldr (bindTC False m tcEnv') tcEnv ds - recEnv' = foldr (bindTC True m recEnv') recEnv ds + let tcEnv' = foldr (bindTC m tcEnv') tcEnv ds setTyConsEnv tcEnv' - setRecordEnv recEnv' --- flag for expansion of record types -type ExpandRecordsFlag = Bool - -bindTC :: ExpandRecordsFlag -> ModuleIdent -> TCEnv -> Decl -> TCEnv -> TCEnv -bindTC _ m tcEnv (DataDecl _ tc tvs cs) = +bindTC :: ModuleIdent -> TCEnv -> Decl -> TCEnv -> TCEnv +bindTC m tcEnv (DataDecl _ tc tvs cs) = bindTypeInfo DataType m tc tvs (map (Just . mkData) cs) where mkData (ConstrDecl _ evs c tys) = mkData' evs c tys mkData (ConOpDecl _ evs ty1 op ty2) = mkData' evs op [ty1, ty2] mkData' evs c tys = DataConstr c (length evs) $ expandMonoTypes m tcEnv (cleanTVars tvs evs) tys -bindTC _ m tcEnv (NewtypeDecl _ tc tvs (NewConstrDecl _ evs c ty)) = +bindTC m tcEnv (NewtypeDecl _ tc tvs (NewConstrDecl _ evs c ty)) = bindTypeInfo RenamingType m tc tvs (DataConstr c (length evs) [ty']) where ty' = expandMonoType' m tcEnv (cleanTVars tvs evs) ty -bindTC erflag m tcEnv t@(TypeDecl _ tc tvs ty) = - bindTypeInfo AliasType m tc tvs expTy - where expTy - | (not erflag) && isRecordDecl t = TypeConstructor qtc tys - | otherwise = expandMonoType' m tcEnv tvs ty - qtc = qualifyWith m tc - tys = map TypeVariable [0..(length tvs - 1)] -bindTC _ _ _ _ = id +bindTC m tcEnv (TypeDecl _ tc tvs ty) = + bindTypeInfo AliasType m tc tvs (expandMonoType' m tcEnv tvs ty) +bindTC _ _ _ = id cleanTVars :: [Ident] -> [Ident] -> [Ident] cleanTVars tvs evs = [if tv `elem` evs then anonId else tv | tv <- tvs] @@ -291,12 +275,12 @@ bindConstrs' m tcEnv tyEnv = foldr (bindData . snd) tyEnv bindLabels :: TCM () bindLabels = do - recEnv <- getRecordEnv - modifyValueEnv $ bindLabels' recEnv + tcEnv <- getTyConsEnv + modifyValueEnv $ bindLabels' tcEnv bindLabels' :: TCEnv -> ValueEnv -> ValueEnv -bindLabels' recEnv tyEnv = foldr (bindFieldLabels . snd) tyEnv - $ localBindings recEnv +bindLabels' tcEnv tyEnv = foldr (bindFieldLabels . snd) tyEnv + $ localBindings tcEnv where bindFieldLabels (AliasType r _ (TypeRecord fs _)) env = foldr (bindField r) env fs @@ -637,17 +621,17 @@ 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 rt) - | isJust rt = do - ty <- tcPattern p (fromJust rt) +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) fts <- mapM (tcFieldPatt tcPattern) fs - alpha <- freshVar id - let rty = TypeRecord fts (Just alpha) - unify p "record pattern" (ppPattern 0 r) ty rty - return rty - | otherwise = do - fts <- mapM (tcFieldPatt tcPattern) fs - return (TypeRecord fts Nothing) + 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 -- In contrast to usual patterns, the type checking routine for arguments of -- function patterns 'tcPatternFP' differs from 'tcPattern' @@ -730,17 +714,17 @@ 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 rt) - | isJust rt = do - ty <- tcPatternFP p (fromJust rt) - 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 - | otherwise = do - fts <- mapM (tcFieldPatt tcPatternFP) fs - return (TypeRecord fts Nothing) +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 tcFieldPatt :: (Position -> Pattern -> TCM Type) -> Field Pattern -> TCM (Ident, Type) @@ -948,23 +932,49 @@ tcExpr p (Case _ _ e alts) = do ty1 >> tcRhs tyEnv0 rhs >>= unify p1 "case branch" doc ty2 -tcExpr _ (RecordConstr fs) = do - fts <- mapM tcFieldExpr fs - return (TypeRecord fts Nothing) +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 p r@(RecordSelection e l) = do - 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 + 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 tcExpr p r@(RecordUpdate fs e) = do - 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 + 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 tcQual :: Position -> Statement -> TCM () tcQual p (StmtExpr _ e) = @@ -991,7 +1001,7 @@ tcFieldExpr :: Field Expression -> TCM (Ident, Type) tcFieldExpr f@(Field p l e) = do lty <- instLabel l ety <- tcExpr p e - unify p "record" (text "Field:" <+> ppFieldExpr f) lty ety + unify p "record field" (text "Field:" <+> ppFieldExpr f) lty ety return (l, ety) -- The function 'tcArrow' checks that its argument can be used as @@ -1036,9 +1046,9 @@ unify p what doc ty1 ty2 = do theta <- getTypeSubst let ty1' = subst theta ty1 let ty2' = subst theta ty2 - m <- getModuleIdent - recEnv <- getRecordEnv - case unifyTypes m recEnv ty1' ty2' of + m <- getModuleIdent + tcEnv <- getTyConsEnv + case unifyTypes m tcEnv ty1' ty2' of Left reason -> report $ errTypeMismatch p what doc m ty1' ty2' reason Right sigma -> modifyTypeSubst (compose sigma) @@ -1055,84 +1065,99 @@ unifyTypes m _ ty (TypeVariable tv) unifyTypes _ _ (TypeConstrained tys1 tv1) (TypeConstrained tys2 tv2) | tv1 == tv2 = Right idSubst | tys1 == tys2 = Right (singleSubst tv1 (TypeConstrained tys2 tv2)) -unifyTypes m recEnv (TypeConstrained tys tv) ty = - foldr (choose . unifyTypes m recEnv ty) (Left (errIncompatibleTypes m ty (head tys))) +unifyTypes m tcEnv (TypeConstrained tys tv) ty = + foldr (choose . unifyTypes m tcEnv ty) (Left (errIncompatibleTypes m ty (head tys))) tys where choose (Left _) theta' = theta' choose (Right theta) _ = Right (bindSubst tv ty theta) -unifyTypes m recEnv ty (TypeConstrained tys tv) = - foldr (choose . unifyTypes m recEnv ty) (Left (errIncompatibleTypes m ty (head tys))) +unifyTypes m tcEnv ty (TypeConstrained tys tv) = + foldr (choose . unifyTypes m tcEnv ty) (Left (errIncompatibleTypes m ty (head tys))) tys where choose (Left _) theta' = theta' choose (Right theta) _ = Right (bindSubst tv ty theta) -unifyTypes m recEnv (TypeConstructor tc1 tys1) (TypeConstructor tc2 tys2) - | tc1 == tc2 = unifyTypeLists m recEnv tys1 tys2 -unifyTypes m recEnv ty1@(TypeConstructor tc _) ty2@(TypeRecord _ _) = - maybe (Left (errIncompatibleTypes m ty1 ty2)) - (\rty -> unifyTypes m recEnv rty ty2) - (lookupRecordType tc recEnv) -unifyTypes m recEnv ty1@(TypeRecord _ _) ty2@(TypeConstructor tc _) = - maybe (Left (errIncompatibleTypes m ty1 ty2)) - (\rty -> unifyTypes m recEnv ty1 rty) - (lookupRecordType tc recEnv) -unifyTypes m recEnv (TypeArrow ty11 ty12) (TypeArrow ty21 ty22) = - unifyTypeLists m recEnv [ty11, ty12] [ty21, ty22] +unifyTypes m tcEnv (TypeConstructor tc1 tys1) (TypeConstructor tc2 tys2) + | tc1 == tc2 = unifyTypeLists m tcEnv tys1 tys2 +--unifyTypes m tcEnv ty1@(TypeConstructor tc _) ty2@(TypeRecord _ _) = +-- maybe (Left (errIncompatibleTypes m ty1 ty2)) +-- (\rty -> unifyTypes m tcEnv rty ty2) +-- (lookupRecordType tc tcEnv) +--unifyTypes m tcEnv ty1@(TypeRecord _ _) ty2@(TypeConstructor tc _) = +-- maybe (Left (errIncompatibleTypes m ty1 ty2)) +-- (\rty -> unifyTypes m tcEnv ty1 rty) +-- (lookupRecordType tc tcEnv) +unifyTypes m tcEnv (TypeArrow ty11 ty12) (TypeArrow ty21 ty22) = + unifyTypeLists m tcEnv [ty11, ty12] [ty21, ty22] unifyTypes _ _ (TypeSkolem k1) (TypeSkolem k2) | k1 == k2 = Right idSubst -unifyTypes m recEnv (TypeRecord fs1 Nothing) tr2@(TypeRecord fs2 Nothing) - | length fs1 == length fs2 = unifyTypedLabels m recEnv fs1 tr2 -unifyTypes m recEnv tr1@(TypeRecord _ Nothing) (TypeRecord fs2 (Just a2)) = - either Left - (\res -> either Left - (Right . compose res) - (unifyTypes m recEnv (TypeVariable a2) tr1)) - (unifyTypedLabels m recEnv fs2 tr1) -unifyTypes m recEnv tr1@(TypeRecord _ (Just _)) tr2@(TypeRecord _ Nothing) = - unifyTypes m recEnv tr2 tr1 -unifyTypes m recEnv (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 recEnv [TypeVariable a1, - TypeRecord (fs1 ++ rs2) Nothing] - [TypeVariable a2, - TypeRecord (fs2 ++ rs1) Nothing])) - (unifyTypedLabels m recEnv 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 (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) + unifyTypeLists :: ModuleIdent -> TCEnv -> [Type] -> [Type] -> Either Doc TypeSubst unifyTypeLists _ _ [] _ = Right idSubst unifyTypeLists _ _ _ [] = Right idSubst -unifyTypeLists m recEnv (ty1 : tys1) (ty2 : tys2) = - either Left unifyTypesTheta (unifyTypeLists m recEnv tys1 tys2) +unifyTypeLists m tcEnv (ty1 : tys1) (ty2 : tys2) = + either Left unifyTypesTheta (unifyTypeLists m tcEnv tys1 tys2) where unifyTypesTheta theta = either Left (Right . flip compose theta) - (unifyTypes m recEnv (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 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 unifyTypedLabels _ _ [] (TypeRecord _ _) = Right idSubst -unifyTypedLabels m recEnv ((l,ty):fs1) tr@(TypeRecord fs2 _) = +unifyTypedLabels m tcEnv ((l,ty):fs1) tr@(TypeRecord fs2 _) = either Left (\r -> maybe (Left (errMissingLabel m l tr)) (\ty' -> either (const (Left (errIncompatibleLabelTypes m l ty ty'))) (Right . flip compose r) - (unifyTypes m recEnv ty ty')) + (unifyTypes m tcEnv ty ty')) (lookup l fs2)) - (unifyTypedLabels m recEnv fs1 tr) + (unifyTypedLabels m tcEnv fs1 tr) unifyTypedLabels _ _ _ _ = internalError "TypeCheck.unifyTypedLabels" -- For each declaration group, the type checker has to ensure that no @@ -1165,6 +1190,11 @@ 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 inst (ForAll n ty) = do tys <- replicateM n freshTypeVar @@ -1254,7 +1284,7 @@ expandPolyType ty = (polyType . normalize) `liftM` expandMonoType [] ty expandMonoType :: [Ident] -> TypeExpr -> TCM Type expandMonoType tvs ty = do - m <- getModuleIdent + m <- getModuleIdent tcEnv <- getTyConsEnv return $ expandMonoType' m tcEnv tvs ty @@ -1268,10 +1298,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 _ _ 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 _ _ ty] -> expandAliasType tys' ty _ -> internalError $ "TypeCheck.expandType " ++ show tc where tys' = map (expandType m tcEnv) tys @@ -1297,21 +1329,29 @@ fsEnv = Set.unions . map (Set.fromList . typeSkolems) . localTypes localTypes :: ValueEnv -> [Type] localTypes tyEnv = [ty | (_, Value _ _ (ForAll _ ty)) <- localBindings tyEnv] --- Lookup record type for given type constructor identifier -lookupRecordType :: QualIdent -> TCEnv -> Maybe Type -lookupRecordType i recEnv = case qualLookupTC i recEnv of - [AliasType _ _ ty] -> Just ty - _ -> Nothing +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 -- --------------------------------------------------------------------------- -- 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 diff --git a/src/Imports.hs b/src/Imports.hs index a852e0701fc07d9cfe1c44353c143fa516cd5dfd..1a4bee53ca8cd5ecbe27e4497cfaa3fb2210319f 100644 --- a/src/Imports.hs +++ b/src/Imports.hs @@ -31,7 +31,6 @@ import Base.CurryTypes (toQualType, toQualTypes) import Base.Messages import Base.TopEnv import Base.Types -import Base.TypeSubst (expandAliasType) import Env.Interface import Env.ModuleAlias (importAliases, initAliasEnv) @@ -558,10 +557,12 @@ expandRecordTypes tcEnv (Label qid r (ForAll n ty)) = Label qid r (ForAll n (expandRecords tcEnv ty)) expandRecords :: TCEnv -> Type -> Type -expandRecords tcEnv (TypeConstructor qid tys) = case qualLookupTC qid tcEnv of - [AliasType _ _ rty@(TypeRecord _ _)] - -> expandRecords tcEnv $ expandAliasType (map (expandRecords tcEnv) tys) rty - _ -> TypeConstructor qid $ map (expandRecords tcEnv) tys +-- jrt 2014-10-09: Deactivated to enable (mutually) recursive record types +-- expandRecords tcEnv (TypeConstructor qid tys) = case qualLookupTC qid tcEnv of +-- [AliasType _ _ rty@(TypeRecord _ _)] +-- -> expandRecords tcEnv $ expandAliasType (map (expandRecords tcEnv) tys) rty +-- _ -> TypeConstructor qid $ map (expandRecords tcEnv) tys +expandRecords tcEnv (TypeConstructor qid tys) = TypeConstructor qid $ map (expandRecords tcEnv) tys expandRecords tcEnv (TypeConstrained tys v) = TypeConstrained (map (expandRecords tcEnv) tys) v expandRecords tcEnv (TypeArrow ty1 ty2) = diff --git a/src/Modules.hs b/src/Modules.hs index aef7346e040d83ab6bae0a6d29c630b7fdd9f377..fba7d4dcde1466b8ff8ea99b0720a2e503fa03fd 100644 --- a/src/Modules.hs +++ b/src/Modules.hs @@ -216,25 +216,23 @@ checkModule opts (env, mdl) = do -- Translating a module -- --------------------------------------------------------------------------- -type Dump = (DumpLevel, CompilerEnv, String) - --- |Translate FlatCurry into the intermediate language 'IL' transModule :: Options -> CompilerEnv -> CS.Module - -> (CompilerEnv, IL.Module, [Dump]) -transModule opts env mdl = (env5, ilCaseComp, dumps) + -> IO (CompilerEnv, IL.Module) +transModule opts env mdl = do + let (desugared , env1) = desugar mdl env + showDump (DumpDesugared , env1, presentCS desugared) + let (simplified, env2) = simplify flat' desugared env1 + showDump (DumpSimplified , env2, presentCS simplified) + let (lifted , env3) = lift simplified env2 + showDump (DumpLifted , env3, presentCS lifted ) + let (il , env4) = ilTrans flat' lifted env3 + showDump (DumpTranslated , env4, presentIL il ) + let (ilCaseComp, env5) = completeCase il env4 + showDump (DumpCaseCompleted, env5, presentIL ilCaseComp) + return (env5, ilCaseComp) where - flat' = FlatCurry `elem` optTargetTypes opts - (desugared , env1) = desugar mdl env - (simplified, env2) = simplify flat' desugared env1 - (lifted , env3) = lift simplified env2 - (il , env4) = ilTrans flat' lifted env3 - (ilCaseComp, env5) = completeCase il env4 - dumps = [ (DumpDesugared , env1, presentCS desugared ) - , (DumpSimplified , env2, presentCS simplified) - , (DumpLifted , env3, presentCS lifted ) - , (DumpTranslated , env4, presentIL il ) - , (DumpCaseCompleted, env5, presentIL ilCaseComp) - ] + flat' = FlatCurry `elem` optTargetTypes opts + showDump = doDump (optDebugOpts opts) presentCS = if dumpRaw then show else show . CS.ppModule presentIL = if dumpRaw then show else show . IL.ppModule dumpRaw = dbDumpRaw (optDebugOpts opts) @@ -250,9 +248,7 @@ writeOutput opts fn (env, modul) = do doDump (optDebugOpts opts) (DumpQualified, env1, show $ CS.ppModule qlfd) writeAbstractCurry opts fn env1 qlfd when withFlat $ do - let (env2, il, dumps) = transModule opts env1 qlfd - -- dump intermediate results - mapM_ (doDump (optDebugOpts opts)) dumps + (env2, il) <- transModule opts env1 qlfd -- generate interface file let intf = exportInterface env2 qlfd writeInterface opts fn intf @@ -349,6 +345,9 @@ writeAbstractCurry opts fname env modul = do uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts useSubDir = optUseSubdir opts +type Dump = (DumpLevel, CompilerEnv, String) + +-- |Translate FlatCurry into the intermediate language 'IL' -- |The 'dump' function writes the selected information to standard output. doDump :: MonadIO m => DebugOpts -> Dump -> m () doDump opts (level, env, dump) = when (level `elem` dbDumpLevels opts) $ do diff --git a/test/RecordTest3.curry b/test/RecordTest3.curry index 3db772c8aedeed3aaf48fe56b03c9257f0094499..9ce14c3e08f3fee5b83bccdb2992ca8919c0c149 100644 --- a/test/RecordTest3.curry +++ b/test/RecordTest3.curry @@ -1,22 +1,56 @@ -type R1 = { f1 :: Bool, f2 :: R2 } +type R1 a b = { f1 :: a, f2 :: b } type R2 = { f3 :: Int } -type R3 a = { f4 :: String, f5 :: a } +type R3 a b = { f5 :: a, f4 :: Maybe b } -data T = T (R3 Int) +type Person = { name :: String, age :: Int } --- f :: R1 -> R1 --- f x = x + 1 +type Address = { person :: Person, street :: String, city :: String } --- g :: R3 Int -> R3 Int --- g x = not x +smith :: Person +smith = { name := "Smith", age := 20 } -r2 :: R2 -r2 = { f3 := 0 } +a :: Address +a = { person := smith, street := "Main Street", city := "New York" } -r1 :: R1 -r1 = { f1 := False, f2 := r2 } +-- p2 = { name := "Doe" } -r3 = { f4 := "", f5 := 1 } +-- data T = T (R3 Int) -e = { f2 := r3 | r1} \ No newline at end of file +--f :: R1 -> R1 +--f x = x + 1 + +--g :: R3 Int -> R3 Int +--g x = not x + +--r1 = { f1 := False, f2 := "" } + +-- r2 :: R2 +-- r2 = { f3 := Just 1 } + +-- r3 :: R1 Bool String +--r3 = { f4 := Just 1, f5 := "" } + +--inc :: Int -> Int +--inc = (+1) + +-- e :: Maybe Bool +--sel1 = (r3 :> f5) + +-- upd1 = { f1 := True | r2 } + +-- upd2 = { f3 := True | r2 } + +-- pat1 { name = "Smith", age = 25 } = True + +-- pat2 { person = p | _} = p + +--r1 :: R1 +--r1 = { f1 := False, f2 := r2 } + +--r3 :: R3 Int +--r3 = { f4 := "", f5 := Just 1 } + +--e = { f2 := r3 | r1} + +--type RR = { f6 :: RR } diff --git a/test/RecursiveRecords.curry b/test/RecursiveRecords.curry new file mode 100644 index 0000000000000000000000000000000000000000..f4e62f027092cfeaae1d2374b85ccb358c27201f --- /dev/null +++ b/test/RecursiveRecords.curry @@ -0,0 +1,27 @@ +type Person = { name :: String, age :: Int, friends :: [Person] } + +john = { name := "John", age := 21, friends := [tim] } + +tim = { name := "Tim", age := 26, friends := [john] } + +ann = { name := "Ann", age := 20, friends := [john,ann] } + +getFriends :: Person -> [Person] +getFriends p = p :> friends + +addFriend :: Person -> Person -> Person +addFriend p friend = { friends := friend : (getFriends p) | p } + +getNames :: Person -> [String] +getNames { friends = fs | _ } = map (\p -> p :> name) fs + +-------------------------------------------------------------------------------- + +type R1 = { r2 :: R2 } +type R2 = { r1 :: R1 } + +rec1 = { r2 := rec2 } +rec2 = { r1 := rec1 } + +type R3 = { f1 :: TSR3 } +type TSR3 = R3 \ No newline at end of file