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
c0d85adc
Commit
c0d85adc
authored
Feb 17, 2015
by
Jan Rasmus Tikovsky
Browse files
Adapted transformations to handle Haskell's record syntax
parent
3ff76be4
Changes
3
Hide whitespace changes
Inline
Side-by-side
src/Transformations/CaseCompletion.hs
View file @
c0d85adc
...
...
@@ -3,6 +3,7 @@
Description : CaseCompletion
Copyright : (c) 2005 , Martin Engelke
2011 - 2014, Björn Peemöller
2015 , Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
...
...
@@ -371,14 +372,18 @@ getCCFromIDecls mid cs (CS.Interface _ _ ds) = complementary cs cinfos
declaresConstr
(
CS
.
ConstrDecl
_
_
cid
_
)
qid
=
unqualify
qid
==
cid
declaresConstr
(
CS
.
ConOpDecl
_
_
_
oid
_
)
qid
=
unqualify
qid
==
oid
declaresConstr
(
CS
.
RecordDecl
_
_
cid
_
)
qid
=
unqualify
qid
==
cid
isNewConstrDecl
qid
(
CS
.
NewConstrDecl
_
_
cid
_
)
=
unqualify
qid
==
cid
isNewConstrDecl
qid
(
CS
.
NewRecordDecl
_
_
cid
_
)
=
unqualify
qid
==
cid
extractConstrDecls
(
CS
.
IDataDecl
_
_
_
cs'
)
=
catMaybes
cs'
extractConstrDecls
_
=
[]
constrInfo
(
CS
.
ConstrDecl
_
_
cid
tys
)
=
(
qualifyWith
mid
cid
,
length
tys
)
constrInfo
(
CS
.
ConOpDecl
_
_
_
oid
_
)
=
(
qualifyWith
mid
oid
,
2
)
constrInfo
(
CS
.
RecordDecl
_
_
cid
fs
)
=
(
qualifyWith
mid
cid
,
length
ls
)
where
ls
=
[
l
|
FieldDecl
_
ls
_
<-
fs
,
l
<-
ls
]
-- Compute complementary constructors
complementary
::
[
QualIdent
]
->
[(
QualIdent
,
Int
)]
->
[(
QualIdent
,
Int
)]
...
...
src/Transformations/CurryToIL.hs
View file @
c0d85adc
...
...
@@ -3,6 +3,7 @@
Description : Translation of Curry into IL
Copyright : (c) 1999 - 2003 Wolfgang Lux
Martin Engelke
2015 Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
...
...
@@ -162,61 +163,13 @@ trForeign f cc (Just ie) = do
-- constrained type variables and skolem types. The former are fixed and
-- the later are replaced by fresh type constructors.
-- Due to possible occurrence of record types, it is necessary to transform
-- them back into their corresponding type constructors first.
trType
::
Type
->
TransM
IL
.
Type
trType
ty
=
trTy
<$>
elimRecordTypes
(
maximum
$
0
:
typeVars
ty
)
ty
where
trTy
(
TypeConstructor
tc
tys
)
=
IL
.
TypeConstructor
tc
(
map
trTy
tys
)
trTy
(
TypeVariable
tv
)
=
IL
.
TypeVariable
tv
trTy
(
TypeConstrained
tys
_
)
=
trTy
(
head
tys
)
trTy
(
TypeArrow
ty1
ty2
)
=
IL
.
TypeArrow
(
trTy
ty1
)
(
trTy
ty2
)
trTy
(
TypeSkolem
k
)
=
IL
.
TypeConstructor
trType
(
TypeConstructor
tc
tys
)
=
IL
.
TypeConstructor
tc
(
map
trTy
tys
)
trType
(
TypeVariable
tv
)
=
IL
.
TypeVariable
tv
trType
(
TypeConstrained
tys
_
)
=
trTy
(
head
tys
)
trType
(
TypeArrow
ty1
ty2
)
=
IL
.
TypeArrow
(
trTy
ty1
)
(
trTy
ty2
)
trType
(
TypeSkolem
k
)
=
IL
.
TypeConstructor
(
qualify
(
mkIdent
(
"_"
++
show
k
)))
[]
trTy
rec
@
(
TypeRecord
_
)
=
internalError
$
"Translation of record not defined: "
++
show
rec
elimRecordTypes
::
Int
->
Type
->
TransM
Type
elimRecordTypes
n
(
TypeConstructor
t
tys
)
=
TypeConstructor
t
<$>
mapM
(
elimRecordTypes
n
)
tys
elimRecordTypes
_
v
@
(
TypeVariable
_
)
=
return
v
elimRecordTypes
n
(
TypeConstrained
tys
v
)
=
flip
TypeConstrained
v
<$>
mapM
(
elimRecordTypes
n
)
tys
elimRecordTypes
n
(
TypeArrow
t1
t2
)
=
TypeArrow
<$>
elimRecordTypes
n
t1
<*>
elimRecordTypes
n
t2
elimRecordTypes
_
s
@
(
TypeSkolem
_
)
=
return
s
elimRecordTypes
n
(
TypeRecord
fs
)
|
null
fs
=
internalError
"CurryToIL.elimRecordTypes: empty record type"
|
otherwise
=
do
(
r
,
n'
,
fs'
)
<-
recordInfo
(
fst
$
head
fs
)
let
vs
=
foldl
(
matchTypeVars
fs
)
Map
.
empty
fs'
tys
=
mapM
(
\
i
->
maybe
(
return
$
TypeVariable
(
i
+
n
))
(
elimRecordTypes
n
)
(
Map
.
lookup
i
vs
))
[
0
..
n'
-
1
]
TypeConstructor
r
<$>
tys
matchTypeVars
::
[(
Ident
,
Type
)]
->
Map
.
Map
Int
Type
->
(
Ident
,
Type
)
->
Map
.
Map
Int
Type
matchTypeVars
fs
vs
(
l
,
ty
)
=
maybe
vs
(
match'
vs
ty
)
(
lookup
l
fs
)
where
match'
vs'
(
TypeVariable
i
)
ty'
=
Map
.
insert
i
ty'
vs'
match'
vs'
(
TypeConstructor
_
tys
)
(
TypeConstructor
_
tys'
)
=
matchList
vs'
tys
tys'
match'
vs'
(
TypeConstrained
tys
_
)
(
TypeConstrained
tys'
_
)
=
matchList
vs'
tys
tys'
match'
vs'
(
TypeArrow
ty1
ty2
)
(
TypeArrow
ty1'
ty2'
)
=
matchList
vs'
[
ty1
,
ty2
]
[
ty1'
,
ty2'
]
match'
vs'
(
TypeSkolem
_
)
(
TypeSkolem
_
)
=
vs'
match'
vs'
(
TypeRecord
fs1
)
(
TypeRecord
fs2
)
=
foldl
(
matchTypeVars
fs2
)
vs'
fs1
match'
_
ty1
ty2
=
internalError
(
"CurryToIL.matchTypeVars: "
++
show
ty1
++
"
\n
"
++
show
ty2
)
matchList
vs1
tys
tys'
=
foldl
(
\
vs'
(
ty1
,
ty2
)
->
match'
vs'
ty1
ty2
)
vs1
(
zip
tys
tys'
)
-- Functions:
-- Each function in the program is translated into a function of the
...
...
@@ -559,17 +512,6 @@ constrType c = do
[
NewtypeConstructor
_
(
ForAllExist
_
_
ty
)]
->
return
ty
_
->
internalError
$
"CurryToIL.constrType: "
++
show
c
recordInfo
::
Ident
->
TransM
(
QualIdent
,
Int
,
[(
Ident
,
Type
)])
recordInfo
f
=
do
tyEnv
<-
getValueEnv
case
lookupValue
f
tyEnv
of
[
Label
_
r
_
]
->
do
tcEnv
<-
getTCEnv
case
qualLookupTC
r
tcEnv
of
[
AliasType
_
n
(
TypeRecord
fs
)]
->
return
(
r
,
n
,
fs
)
_
->
internalError
$
"CurryToIL.recordInfo: "
++
show
f
_
->
internalError
$
"CurryToIL.recordInfo: "
++
show
f
-- The list of import declarations in the intermediate language code is
-- determined by collecting all module qualifiers used in the current
-- module.
...
...
src/Transformations/Desugar.hs
View file @
c0d85adc
...
...
@@ -4,6 +4,7 @@
Copyright : (c) 2001 - 2004 Wolfgang Lux
Martin Engelke
2011 - 2015 Björn Peemöller
2015 Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
...
...
@@ -68,7 +69,7 @@ import Control.Arrow (first, second)
import
Control.Monad
(
mplus
)
import
qualified
Control.Monad.State
as
S
(
State
,
runState
,
gets
,
modify
)
import
Data.List
((
\\
),
nub
,
tails
)
import
Data.Maybe
(
fromMaybe
)
import
Data.Maybe
(
fromMaybe
,
catMaybes
)
import
qualified
Data.Set
as
Set
(
Set
,
empty
,
member
,
insert
)
import
Curry.Base.Ident
...
...
@@ -279,6 +280,8 @@ dsNonLinear env (InfixPattern t1 op t2) = do
return
(
env2
,
InfixPattern
t1'
op
t2'
)
dsNonLinear
env
(
ParenPattern
t
)
=
second
ParenPattern
<$>
dsNonLinear
env
t
dsNonLinear
env
(
RecordPattern
c
fs
)
=
second
(
RecordPattern
c
)
<$>
mapAccumM
(
dsField
dsNonLinear
)
env
fs
dsNonLinear
env
(
TuplePattern
pos
ts
)
=
second
(
TuplePattern
pos
)
<$>
mapAccumM
dsNonLinear
env
ts
dsNonLinear
env
(
ListPattern
pos
ts
)
=
second
(
ListPattern
pos
)
...
...
@@ -291,13 +294,6 @@ dsNonLinear env (LazyPattern r t) = second (LazyPattern r)
<$>
dsNonLinear
env
t
dsNonLinear
env
fp
@
(
FunctionPattern
_
_
)
=
dsNonLinearFuncPat
env
fp
dsNonLinear
env
fp
@
(
InfixFuncPattern
_
_
_
)
=
dsNonLinearFuncPat
env
fp
dsNonLinear
env
(
RecordPattern
fs
r
)
=
do
(
env1
,
fs'
)
<-
mapAccumM
dsField
env
fs
(
env2
,
r'
)
<-
case
r
of
Nothing
->
return
(
env1
,
Nothing
)
Just
r0
->
second
Just
<$>
dsNonLinear
env1
r0
return
(
env2
,
RecordPattern
fs'
r'
)
where
dsField
e
(
Field
p
i
t
)
=
second
(
Field
p
i
)
<$>
dsNonLinear
e
t
dsNonLinearFuncPat
::
NonLinearEnv
->
Pattern
->
DsM
(
NonLinearEnv
,
Pattern
)
dsNonLinearFuncPat
(
vis
,
eqs
)
fp
=
do
...
...
@@ -321,6 +317,8 @@ substPat s (ConstructorPattern c ps) = ConstructorPattern c
substPat
s
(
InfixPattern
p1
op
p2
)
=
InfixPattern
(
substPat
s
p1
)
op
(
substPat
s
p2
)
substPat
s
(
ParenPattern
p
)
=
ParenPattern
(
substPat
s
p
)
substPat
s
(
RecordPattern
c
fs
)
=
RecordPattern
c
(
map
substField
fs
)
where
substField
(
Field
pos
l
pat
)
=
Field
pos
l
(
substPat
s
pat
)
substPat
s
(
TuplePattern
pos
ps
)
=
TuplePattern
pos
$
map
(
substPat
s
)
ps
substPat
s
(
ListPattern
pos
ps
)
=
ListPattern
pos
$
map
(
substPat
s
)
ps
substPat
s
(
AsPattern
v
p
)
=
AsPattern
(
fromMaybe
v
(
lookup
v
s
))
...
...
@@ -329,9 +327,6 @@ substPat s (LazyPattern r p) = LazyPattern r (substPat s p)
substPat
s
(
FunctionPattern
f
ps
)
=
FunctionPattern
f
$
map
(
substPat
s
)
ps
substPat
s
(
InfixFuncPattern
p1
op
p2
)
=
InfixFuncPattern
(
substPat
s
p1
)
op
(
substPat
s
p2
)
substPat
s
(
RecordPattern
fs
p
)
=
RecordPattern
(
map
substField
fs
)
(
substPat
s
<$>
p
)
where
substField
(
Field
pos
i
t
)
=
Field
pos
i
(
substPat
s
t
)
-- -----------------------------------------------------------------------------
-- Desugaring of functional patterns
...
...
@@ -374,6 +369,8 @@ elimFP bs (InfixPattern t1 op t2) = do
(
bs2
,
t2'
)
<-
elimFP
bs1
t2
return
(
bs2
,
InfixPattern
t1'
op
t2'
)
elimFP
bs
(
ParenPattern
t
)
=
second
ParenPattern
<$>
elimFP
bs
t
elimFP
bs
(
RecordPattern
c
fs
)
=
second
(
RecordPattern
c
)
<$>
mapAccumM
(
dsField
elimFP
)
bs
fs
elimFP
bs
(
TuplePattern
pos
ts
)
=
second
(
TuplePattern
pos
)
<$>
mapAccumM
elimFP
bs
ts
elimFP
bs
(
ListPattern
pos
ts
)
=
second
(
ListPattern
pos
)
...
...
@@ -386,9 +383,6 @@ elimFP bs p@(FunctionPattern _ _) = do
elimFP
bs
p
@
(
InfixFuncPattern
_
_
_
)
=
do
v
<-
freshMonoTypeVar
"_#funpatt"
p
return
((
p
,
v
)
:
bs
,
VariablePattern
v
)
elimFP
bs
(
RecordPattern
fs
r
)
=
second
(
flip
RecordPattern
r
)
<$>
mapAccumM
elimField
bs
fs
where
elimField
b
(
Field
p
i
t
)
=
second
(
Field
p
i
)
<$>
elimFP
b
t
genFPExpr
::
Position
->
[
Ident
]
->
[
LazyBinding
]
->
([
Decl
],
[
Expression
])
genFPExpr
p
vs
bs
...
...
@@ -443,6 +437,19 @@ fp2Expr t = internalError $
-- 't' is a variable or an as-pattern are replaced by 't' in combination
-- with a local declaration for 'v'.
-- Record patterns are transformed into normal constructor patterns by
-- rearranging fields in the order of the record's declaration, adding
-- fresh variables in place of omitted fields, and discarding the field
-- labels.
-- Note: By rearranging fields here we loose the ability to comply
-- strictly with the Haskell 98 pattern matching semantics, which matches
-- fields of a record pattern in the order of their occurrence in the
-- pattern. However, keep in mind that Haskell matches alternatives from
-- top to bottom and arguments within an equation or alternative from
-- left to right, which is not the case in Curry except for rigid case
-- expressions.
dsPattern
::
Position
->
[
Decl
]
->
Pattern
->
DsM
([
Decl
],
Pattern
)
dsPattern
_
ds
v
@
(
VariablePattern
_
)
=
return
(
ds
,
v
)
dsPattern
p
ds
(
LiteralPattern
l
)
=
do
...
...
@@ -457,33 +464,30 @@ dsPattern p ds (ConstructorPattern c [t]) = do
(
if
isNewtypeConstr
tyEnv
c
then
id
else
second
(
constrPat
c
))
<$>
(
dsPattern
p
ds
t
)
where
constrPat
c'
t'
=
ConstructorPattern
c'
[
t'
]
dsPattern
p
ds
(
ConstructorPattern
c
ts
)
=
dsPattern
p
ds
(
ConstructorPattern
c
ts
)
=
second
(
ConstructorPattern
c
)
<$>
mapAccumM
(
dsPattern
p
)
ds
ts
dsPattern
p
ds
(
InfixPattern
t1
op
t2
)
=
dsPattern
p
ds
(
InfixPattern
t1
op
t2
)
=
dsPattern
p
ds
(
ConstructorPattern
op
[
t1
,
t2
])
dsPattern
p
ds
(
ParenPattern
t
)
=
dsPattern
p
ds
t
dsPattern
p
ds
(
TuplePattern
pos
ts
)
=
dsPattern
p
ds
(
ParenPattern
t
)
=
dsPattern
p
ds
t
dsPattern
p
ds
(
RecordPattern
c
fs
)
=
do
tyEnv
<-
getValueEnv
let
(
ls
,
_
)
=
conType
c
tyEnv
ts
=
map
(
dsLabel
(
VariablePattern
anonId
)
(
map
field2Tuple
fs
))
ls
dsPattern
p
ds
(
ConstructorPattern
c
ts
)
dsPattern
p
ds
(
TuplePattern
pos
ts
)
=
dsPattern
p
ds
(
ConstructorPattern
(
tupleConstr
ts
)
ts
)
where
tupleConstr
ts'
=
addRef
pos
$
if
null
ts'
then
qUnitId
else
qTupleId
(
length
ts'
)
dsPattern
p
ds
(
ListPattern
pos
ts
)
=
dsPattern
p
ds
(
ListPattern
pos
ts
)
=
second
(
dsList
pos
cons
nil
)
<$>
mapAccumM
(
dsPattern
p
)
ds
ts
where
nil
p'
=
ConstructorPattern
(
addRef
p'
qNilId
)
[]
cons
p'
t
ts'
=
ConstructorPattern
(
addRef
p'
qConsId
)
[
t
,
ts'
]
dsPattern
p
ds
(
AsPattern
v
t
)
=
dsAs
p
v
<$>
dsPattern
p
ds
t
dsPattern
p
ds
(
LazyPattern
r
t
)
=
dsLazy
r
p
ds
t
dsPattern
p
ds
(
FunctionPattern
f
ts
)
=
dsPattern
p
ds
(
AsPattern
v
t
)
=
dsAs
p
v
<$>
dsPattern
p
ds
t
dsPattern
p
ds
(
LazyPattern
r
t
)
=
dsLazy
r
p
ds
t
dsPattern
p
ds
(
FunctionPattern
f
ts
)
=
second
(
FunctionPattern
f
)
<$>
mapAccumM
(
dsPattern
p
)
ds
ts
dsPattern
p
ds
(
InfixFuncPattern
t1
f
t2
)
=
dsPattern
p
ds
(
FunctionPattern
f
[
t1
,
t2
])
dsPattern
p
ds
(
RecordPattern
fs
_
)
|
null
fs
=
internalError
"Desugar.dsPattern: empty record"
|
otherwise
=
do
r
<-
recordFromField
(
fieldLabel
(
head
fs
))
fs'
<-
(
map
fst
.
snd
)
<$>
lookupRecord
r
let
ts
=
map
(
dsLabel
(
map
field2Tuple
fs
))
fs'
dsPattern
p
ds
(
ConstructorPattern
r
ts
)
where
dsLabel
fs'
l
=
fromMaybe
(
VariablePattern
anonId
)
(
lookup
l
fs'
)
dsLiteral
::
Literal
->
DsM
(
Either
Literal
([
SrcRef
],
[
Literal
]))
dsLiteral
c
@
(
Char
_
_
)
=
return
$
Left
c
...
...
@@ -570,21 +574,57 @@ booleanGuards _ _ [] = False
booleanGuards
tyEnv
tcEnv
(
CondExpr
_
g
_
:
es
)
=
not
(
null
es
)
||
typeOf
tyEnv
tcEnv
g
==
boolType
-- Record construction expressions are transformed into normal
-- constructor applications by rearranging fields in the order of the
-- record's declaration, passing `Prelude.undefined` in place of
-- omitted fields, and discarding the field labels. The transformation of
-- record update expressions is a bit more involved as we must match the
-- updated expression with all valid constructors of the expression's
-- type. As stipulated by the Haskell 98 Report, a record update
-- expression @e { l_1 = e_1, ..., l_k = e_k }@ succeeds only if @e@ reduces to
-- a value @C e'_1 ... e'_n@ such that @C@'s declaration contains all
-- field labels @l_1,...,l_k@. In contrast to Haskell we do not report
-- an error if this is not the case but rather fail only the current
-- solution.
dsExpr
::
Position
->
Expression
->
DsM
Expression
dsExpr
p
(
Literal
l
)
=
dsExpr
p
(
Literal
l
)
=
dsLiteral
l
>>=
either
(
return
.
Literal
)
(
\
(
pos
,
ls
)
->
dsExpr
p
$
List
pos
$
map
Literal
ls
)
dsExpr
_
var
@
(
Variable
v
)
|
isAnonId
(
unqualify
v
)
=
return
prelUnknown
|
otherwise
=
return
var
dsExpr
_
c
@
(
Constructor
_
)
=
return
c
dsExpr
p
(
Paren
e
)
=
dsExpr
p
e
dsExpr
p
(
Typed
e
ty
)
=
Typed
<$>
dsExpr
p
e
<*>
dsTypeExpr
ty
dsExpr
p
(
Tuple
pos
es
)
=
apply
(
Constructor
$
tupleConstr
es
)
|
isAnonId
(
unqualify
v
)
=
return
prelUnknown
|
otherwise
=
return
var
dsExpr
_
c
@
(
Constructor
_
)
=
return
c
dsExpr
p
(
Paren
e
)
=
dsExpr
p
e
dsExpr
p
(
Typed
e
ty
)
=
Typed
<$>
dsExpr
p
e
<*>
dsTypeExpr
ty
dsExpr
p
(
Record
c
fs
)
=
do
tyEnv
<-
getValueEnv
let
(
ls
,
_
)
=
conType
c
tyEnv
es
=
map
(
dsLabel
prelFailed
(
map
field2Tuple
fs
))
ls
dsExpr
p
$
apply
(
Constructor
c
)
es
dsExpr
p
(
RecordUpdate
e
fs
)
=
do
tyEnv
<-
getValueEnv
tcEnv
<-
getTyConsEnv
ty
<-
getTypeOf
e
let
(
TypeConstructor
tc
_
)
=
arrowBase
ty
alts
<-
mapM
(
updateAlt
tc
)
(
constructors
tc
)
dsExpr
p
$
Case
(
srcRefOf
p
)
Flex
e
(
map
(
caseAlt
p
)
(
concat
alts
))
where
ls
=
map
fieldLabel
fs
updateAlt
_
(
DataConstr
_
_
_
)
=
return
[]
updateAlt
tc'
(
RecordConstr
c
_
labels
tys
)
|
all
(`
elem
`
labels
)
ls
=
do
vs
<-
mapM
(
freshMonoTypeVar
"_#rec"
.
VariablePattern
)
labels
let
es
=
map
(
\
v
->
dsLabel
(
mkVar
v
)
(
map
field2Tuple
fs
)
v
)
vs
qc
=
qualifyLike
tc'
c
return
[(
constrPat
qc
vs
,
apply
(
Constructor
qc
)
es
)]
|
otherwise
=
return
[]
constrPat
qc'
vs'
=
ConstructorPattern
qc'
(
map
VariablePattern
vs'
)
dsExpr
p
(
Tuple
pos
es
)
=
apply
(
Constructor
$
tupleConstr
es
)
<$>
mapM
(
dsExpr
p
)
es
where
tupleConstr
es1
=
addRef
pos
$
if
null
es1
then
qUnitId
else
qTupleId
(
length
es1
)
dsExpr
p
(
List
pos
es
)
=
dsList
pos
cons
nil
<$>
mapM
(
dsExpr
p
)
es
dsExpr
p
(
List
pos
es
)
=
dsList
pos
cons
nil
<$>
mapM
(
dsExpr
p
)
es
where
nil
p'
=
Constructor
(
addRef
p'
qNilId
)
cons
p'
=
Apply
.
Apply
(
Constructor
$
addRef
p'
qConsId
)
dsExpr
p
(
ListCompr
r
e
[]
)
=
dsExpr
p
(
List
[
r
,
r
]
[
e
])
...
...
@@ -653,20 +693,13 @@ dsExpr p (Case r ct e alts)
mkCase
m1
v
e1
alts1
|
v
`
elem
`
qfv
m1
alts1
=
Let
[
varDecl
p
v
e1
]
(
Case
r
ct
(
mkVar
v
)
alts1
)
|
otherwise
=
Case
r
ct
e1
alts1
dsExpr
p
(
RecordConstr
fs
)
|
null
fs
=
internalError
"Desugar.dsExpr: empty record construction"
|
otherwise
=
do
r
<-
recordFromField
(
fieldLabel
(
head
fs
))
dsRecordConstr
p
r
(
map
field2Tuple
fs
)
dsExpr
p
(
RecordSelection
e
l
)
=
do
m
<-
getModuleIdent
r
<-
recordFromField
l
dsExpr
p
(
Apply
(
Variable
(
qualRecSelectorId
m
r
l
))
e
)
dsExpr
p
(
RecordUpdate
fs
rexpr
)
|
null
fs
=
internalError
"Desugar.dsExpr: empty record update"
|
otherwise
=
do
r
<-
recordFromField
(
fieldLabel
(
head
fs
))
dsRecordUpdate
p
r
rexpr
(
map
field2Tuple
fs
)
dsLabel
::
a
->
[(
Ident
,
a
)]
->
Ident
->
a
dsLabel
def
fs
l
=
fromMaybe
def
(
lookup
l
fs
)
dsField
::
(
a
->
b
->
DsM
(
a
,
b
))
->
a
->
Field
b
->
DsM
(
a
,
Field
b
)
dsField
ds
z
(
Field
p
l
x
)
=
do
(
z'
,
x'
)
<-
ds
z
x
return
(
z'
,
Field
p
l
x'
)
dsTypeExpr
::
TypeExpr
->
DsM
TypeExpr
dsTypeExpr
ty
=
do
...
...
@@ -686,8 +719,6 @@ expandType _ tc@(TypeConstrained _ _) = tc
expandType
tcEnv
(
TypeArrow
ty1
ty2
)
=
TypeArrow
(
expandType
tcEnv
ty1
)
(
expandType
tcEnv
ty2
)
expandType
_
ts
@
(
TypeSkolem
_
)
=
ts
expandType
tcEnv
(
TypeRecord
fs
)
=
TypeRecord
(
map
(
\
(
l
,
ty
)
->
(
l
,
expandType
tcEnv
ty
))
fs
)
-- If an alternative in a case expression has boolean guards and all of
-- these guards return 'False', the enclosing case expression does
...
...
@@ -731,80 +762,64 @@ isCompatible _ _ = False
-- Desugaring of Records
-- -----------------------------------------------------------------------------
recordFromField
::
Ident
->
DsM
QualIdent
recordFromField
lbl
=
do
tyEnv
<-
getValueEnv
case
lookupValue
lbl
tyEnv
of
[
Label
_
r
_
]
->
return
r
_
->
internalError
$
"Desugar.recordFromField: unknown label: "
++
show
lbl
lookupRecord
::
QualIdent
->
DsM
(
Int
,
[(
Ident
,
Type
)])
lookupRecord
r
=
do
tcEnv
<-
getTyConsEnv
case
qualLookupTC
r
tcEnv
of
[
AliasType
_
n
(
TypeRecord
fs
)]
->
return
(
n
,
fs
)
_
->
internalError
$
"Desugar.lookupRecord: no record: "
++
show
r
-- As an extension to the Curry language the compiler supports Haskell's
-- record syntax, which introduces field labels for data and renaming
-- types. Field labels can be used in constructor declarations, patterns,
-- and expressions. For further convenience, an implicit selector
-- function is introduced for each field label.
-- Generate selection functions for record labels and replace record
-- constructor declarations by normal constructor declarations
dsRecordDecl
::
Decl
->
DsM
[
Decl
]
dsRecordDecl
(
TypeDecl
p
r
vs
(
RecordType
fss
))
=
do
m
<-
getModuleIdent
let
qr
=
qualifyWith
m
r
(
n
,
fs'
)
<-
lookupRecord
qr
let
tys
=
concatMap
(
\
(
ls
,
ty
)
->
replicate
(
length
ls
)
ty
)
fss
--tys' = map (elimRecordTypes tyEnv) tys
rdecl
=
DataDecl
p
r
vs
[
ConstrDecl
p
[]
r
tys
]
rty'
=
TypeConstructor
qr
(
map
TypeVariable
[
0
..
n
-
1
])
rcts'
=
ForAllExist
0
n
(
foldr
TypeArrow
rty'
(
map
snd
fs'
))
rfuncs
<-
mapM
(
genRecordFuncs
p
qr
rty'
(
map
fst
fs'
))
fs'
modifyValueEnv
(
bindGlobalInfo
(
flip
DataConstructor
(
length
tys
))
m
r
rcts'
)
return
$
rdecl
:
concat
rfuncs
dsRecordDecl
(
DataDecl
p
tc
tvs
cs
)
=
do
m
<-
getModuleIdent
let
qcs
=
map
(
qualifyWith
m
.
constrId
)
cs
selFuns
<-
mapM
(
genSelectFunc
p
qcs
)
labels
return
$
DataDecl
p
tc
tvs
(
map
unlabelConstr
cs
)
:
selFuns
where
labels
=
nub
$
concatMap
recordLabels
cs
dsRecordDecl
(
NewtypeDecl
p
tc
tvs
nc
)
=
do
m
<-
getModuleIdent
let
qc
=
qualifyWith
m
(
nconstrId
nc
)
selFun
<-
mapM
(
genSelectFunc
p
[
qc
])
(
nrecordLabels
nc
)
return
$
NewtypeDecl
p
tc
tvs
(
unlabelNewConstr
nc
)
:
selFun
dsRecordDecl
d
=
return
[
d
]
genRecordFuncs
::
Position
->
QualIdent
->
Type
->
[
Ident
]
->
(
Ident
,
Type
)
->
DsM
[
Decl
]
genRecordFuncs
p
r
rty
ls
(
l
,
ty
)
=
do
m
<-
getModuleIdent
let
(
selId
,
selFunc
)
=
genSelectFunc
p
r
ls
l
(
updId
,
updFunc
)
=
genUpdateFunc
p
r
ls
l
selType
=
polyType
(
TypeArrow
rty
ty
)
updType
=
polyType
(
TypeArrow
rty
$
TypeArrow
ty
rty
)
modifyValueEnv
(
bindFun
m
selId
1
selType
.
bindFun
m
updId
2
updType
)
return
[
selFunc
,
updFunc
]
genSelectFunc
::
Position
->
QualIdent
->
[
Ident
]
->
Ident
->
(
Ident
,
Decl
)
genSelectFunc
p
r
ls
l
=
(
selId
,
funDecl
p
selId
[
cpatt
]
(
mkVar
l
))
-- Generate selection function for a record label
genSelectFunc
::
Position
->
[
QualIdent
]
->
Ident
->
DsM
Decl
genSelectFunc
p
qcs
l
=
do
m
<-
getModuleIdent
tyEnv
<-
getValueEnv
eqs
<-
concat
<$>
mapM
(
selectorEqn
l
)
qcs
let
(
_
,
ty
)
=
conType
(
head
qcs
)
tyEnv
(
tys
,
rty
)
=
arrowUnapply
(
instType
ty
)
selType
=
polyType
(
TypeArrow
rty
(
tys
!!
n
))
selId
=
qualifyWith
m
l
modifyValueEnv
$
bindFun
m
selId
1
selType
return
$
FunctionDecl
p
selId
[
funEqn
selId
[
pat
]
e
|
(
pat
,
e
)
<-
eqs
]
where
selId
=
recSelectorId
r
l
cpatt
=
ConstructorPattern
r
(
map
VariablePattern
ls
)
funEqn
f
ps
e
=
Equation
p
(
FunLhs
f
ps
)
(
SimpleRhs
p
e
[]
)
genUpdateFunc
::
Position
->
QualIdent
->
[
Ident
]
->
Ident
->
(
Ident
,
Decl
)
genUpdateFunc
p
r
ls
l
=
(
updId
,
funDecl
p
updId
[
cpatt1
,
cpatt2
]
cexpr
)
where
updId
=
recUpdateId
r
l
vs
=
[
VariablePattern
(
if
v
==
l
then
anonId
else
v
)
|
v
<-
ls
]
cpatt1
=
ConstructorPattern
r
vs
cpatt2
=
VariablePattern
l
cexpr
=
apply
(
Constructor
r
)
(
map
mkVar
ls
)
dsRecordConstr
::
Position
->
QualIdent
->
[(
Ident
,
Expression
)]
->
DsM
Expression
dsRecordConstr
p
r
fs
=
do
fs'
<-
(
map
fst
.
snd
)
<$>
lookupRecord
r
let
cts
=
map
(
\
l
->
fromMaybe
(
internalError
"Desugar.dsRecordConstr"
)
(
lookup
l
fs
))
fs'
dsExpr
p
(
apply
(
Constructor
r
)
cts
)
dsRecordUpdate
::
Position
->
QualIdent
->
Expression
->
[(
Ident
,
Expression
)]
->
DsM
Expression
dsRecordUpdate
p
r
rexpr
fs
=
do
m
<-
getModuleIdent
dsExpr
p
(
foldl
(
genRecordUpdate
m
r
)
rexpr
fs
)
where
genRecordUpdate
m1
r1
rexpr1
(
l
,
e
)
=
apply
(
Variable
$
qualRecUpdateId
m1
r1
l
)
[
rexpr1
,
e
]
-- Generate pattern and rhs for selection function and
-- add its type to the value environment
selectorEqn
::
Ident
->
QualIdent
->
DsM
[(
Pattern
,
Expression
)]
selectorEqn
l
qc
=
do
tyEnv
<-
getValueEnv
let
(
ls
,
_
)
=
conType
qc
tyEnv
case
elemIndex
l
ls
of
Just
n
->
do
vs
<-
mapM
(
freshMonoTypeVar
"_#rec"
.
VariablePattern
)
ls
return
[(
ConstructorPattern
qc
vs
,
Variable
(
vs
!!
n
))]
Nothing
->
return
[]
-- Transform record constructor declarations into normal declarations
unlabelConstr
::
ConstrDecl
->
ConstrDecl
unlabelConstr
(
RecordDecl
p
evs
c
fs
)
=
ConstrDecl
p
evs
c
tys
where
tys
=
[
ty
|
FieldDecl
_
ls
ty
<-
fs
,
_
<-
ls
]
unlabelConstr
c
=
c
unlabelNewConstr
::
NewConstrDecl
->
NewConstrDecl
unlabelNewConstr
(
NewRecordDecl
p
evs
nc
(
_
,
ty
))
=
NewConstrDecl
p
evs
nc
ty
unlabelNewConstr
c
=
c
-- -----------------------------------------------------------------------------
-- Desugaring of List Comprehension
...
...
@@ -978,3 +993,23 @@ apply = foldl Apply
mkVar
::
Ident
->
Expression
mkVar
=
Variable
.
qualify
-- The function 'instType' instantiates the universally quantified
-- type variables of a type scheme with fresh type variables. Since this
-- function is used only to instantiate the closed types of record
-- constructors (Recall that no existentially quantified type
-- variables are allowed for records), the compiler can reuse the same
-- monomorphic type variables for every instantiated type.
instType
::
ExistTypeScheme
->
Type
instType
(
ForAllExist
_
_
ty
)
=
inst
ty
where
inst
(
TypeConstructor
tc
tys
)
=
TypeConstructor
tc
(
map
inst
tys
)
inst
(
TypeVariable
tv
)
=
TypeVariable
(
-
1
-
tv
)
inst
(
TypeArrow
ty1
ty2
)
=
TypeArrow
(
inst
ty1
)
(
inst
ty2
)
constructors
::
QualIdent
->
TCEnv
->
[
DataConstr
]
constructors
c
tcEnv
=
case
qualLookupTC
c
of
[
DataType
_
_
cs
]
->
cs
[
RenamingType
_
_
c
]
->
[
c
]
_
->
internalError
$
"Transformations.Desugar.constructors: "
++
show
c
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