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 ...@@ -4,6 +4,8 @@ Change log for curry-frontend
Under development Under development
================= =================
* Enabled declaration of (mutually) recursive record types
* Removed expansion of record types in type error messages * Removed expansion of record types in type error messages
* Replaced MessageM monad with CYT monads and moved CYT monads to curry-base * 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) ...@@ -31,7 +31,6 @@ import Base.CurryTypes (toQualType, toQualTypes)
import Base.Messages import Base.Messages
import Base.TopEnv import Base.TopEnv
import Base.Types import Base.Types
import Base.TypeSubst (expandAliasType)
import Env.Interface import Env.Interface
import Env.ModuleAlias (importAliases, initAliasEnv) import Env.ModuleAlias (importAliases, initAliasEnv)
...@@ -558,10 +557,12 @@ expandRecordTypes tcEnv (Label qid r (ForAll n ty)) = ...@@ -558,10 +557,12 @@ expandRecordTypes tcEnv (Label qid r (ForAll n ty)) =
Label qid r (ForAll n (expandRecords tcEnv ty)) Label qid r (ForAll n (expandRecords tcEnv ty))
expandRecords :: TCEnv -> Type -> Type expandRecords :: TCEnv -> Type -> Type
expandRecords tcEnv (TypeConstructor qid tys) = case qualLookupTC qid tcEnv of -- jrt 2014-10-09: Deactivated to enable (mutually) recursive record types
[AliasType _ _ rty@(TypeRecord _ _)] -- expandRecords tcEnv (TypeConstructor qid tys) = case qualLookupTC qid tcEnv of
-> expandRecords tcEnv $ expandAliasType (map (expandRecords tcEnv) tys) rty -- [AliasType _ _ rty@(TypeRecord _ _)]
_ -> TypeConstructor qid $ map (expandRecords tcEnv) tys -- -> 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) = expandRecords tcEnv (TypeConstrained tys v) =
TypeConstrained (map (expandRecords tcEnv) tys) v TypeConstrained (map (expandRecords tcEnv) tys) v
expandRecords tcEnv (TypeArrow ty1 ty2) = expandRecords tcEnv (TypeArrow ty1 ty2) =
......
...@@ -216,25 +216,23 @@ checkModule opts (env, mdl) = do ...@@ -216,25 +216,23 @@ checkModule opts (env, mdl) = do
-- Translating a module -- Translating a module
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
type Dump = (DumpLevel, CompilerEnv, String)
-- |Translate FlatCurry into the intermediate language 'IL'
transModule :: Options -> CompilerEnv -> CS.Module transModule :: Options -> CompilerEnv -> CS.Module
-> (CompilerEnv, IL.Module, [Dump]) -> IO (CompilerEnv, IL.Module)
transModule opts env mdl = (env5, ilCaseComp, dumps) 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 where
flat' = FlatCurry `elem` optTargetTypes opts flat' = FlatCurry `elem` optTargetTypes opts
(desugared , env1) = desugar mdl env showDump = doDump (optDebugOpts opts)
(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)
]
presentCS = if dumpRaw then show else show . CS.ppModule presentCS = if dumpRaw then show else show . CS.ppModule
presentIL = if dumpRaw then show else show . IL.ppModule presentIL = if dumpRaw then show else show . IL.ppModule
dumpRaw = dbDumpRaw (optDebugOpts opts) dumpRaw = dbDumpRaw (optDebugOpts opts)
...@@ -250,9 +248,7 @@ writeOutput opts fn (env, modul) = do ...@@ -250,9 +248,7 @@ writeOutput opts fn (env, modul) = do
doDump (optDebugOpts opts) (DumpQualified, env1, show $ CS.ppModule qlfd) doDump (optDebugOpts opts) (DumpQualified, env1, show $ CS.ppModule qlfd)
writeAbstractCurry opts fn env1 qlfd writeAbstractCurry opts fn env1 qlfd
when withFlat $ do when withFlat $ do
let (env2, il, dumps) = transModule opts env1 qlfd (env2, il) <- transModule opts env1 qlfd
-- dump intermediate results
mapM_ (doDump (optDebugOpts opts)) dumps
-- generate interface file -- generate interface file
let intf = exportInterface env2 qlfd let intf = exportInterface env2 qlfd
writeInterface opts fn intf writeInterface opts fn intf
...@@ -349,6 +345,9 @@ writeAbstractCurry opts fname env modul = do ...@@ -349,6 +345,9 @@ writeAbstractCurry opts fname env modul = do
uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts
useSubDir = optUseSubdir 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. -- |The 'dump' function writes the selected information to standard output.
doDump :: MonadIO m => DebugOpts -> Dump -> m () doDump :: MonadIO m => DebugOpts -> Dump -> m ()
doDump opts (level, env, dump) = when (level `elem` dbDumpLevels opts) $ do 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 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 type Address = { person :: Person, street :: String, city :: String }
-- f x = x + 1
-- g :: R3 Int -> R3 Int smith :: Person
-- g x = not x smith = { name := "Smith", age := 20 }
r2 :: R2 a :: Address
r2 = { f3 := 0 } a = { person := smith, street := "Main Street", city := "New York" }
r1 :: R1 -- p2 = { name := "Doe" }
r1 = { f1 := False, f2 := r2 }
r3 = { f4 := "", f5 := 1 } -- data T = T (R3 Int)
e = { f2 := r3 | r1} --f :: R1 -> R1
\ No newline at end of file --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