Commit 259e2bd8 authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky

Adapted type checking to enable (mutually) recursive record types

parent 0dc34cc0
......@@ -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
......
This diff is collapsed.
......@@ -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) =
......
......@@ -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
......
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 }
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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment