Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
curry
curry-frontend
Commits
259e2bd8
Commit
259e2bd8
authored
Oct 09, 2014
by
Jan Rasmus Tikovsky
Browse files
Adapted type checking to enable (mutually) recursive record types
parent
0dc34cc0
Changes
6
Expand all
Hide whitespace changes
Inline
Side-by-side
CHANGELOG.md
View file @
259e2bd8
...
...
@@ -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/Checks/TypeCheck.hs
View file @
259e2bd8
This diff is collapsed.
Click to expand it.
src/Imports.hs
View file @
259e2bd8
...
...
@@ -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
View file @
259e2bd8
...
...
@@ -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
View file @
259e2bd8
type R1 = { f1 ::
Bool
, f2 ::
R2
}
type R1
a b
= { f1 ::
a
, f2 ::
b
}
type R2 = { f3 :: Int }
type R3 a = { f
4
::
String
, f
5
::
a
}
type R3 a
b
= { f
5
::
a
, f
4
::
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
0 → 100644
View file @
259e2bd8
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
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment