Adapted type checking to enable (mutually) recursive record types

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

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) =

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

test/RecordTest3.curry

-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 }

test/RecursiveRecords.curry

+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