Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
curry
curry-frontend
Commits
d7c80601
Commit
d7c80601
authored
Jun 11, 2018
by
Kai-Oliver Prott
Committed by
Finn Teegen
Jul 09, 2018
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Remove some redundancy in TypedFlatCurry
parent
952f1c6a
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
19 additions
and
14 deletions
+19
-14
src/Generators/GenFlatCurry.hs
src/Generators/GenFlatCurry.hs
+2
-2
src/Generators/GenTypedFlatCurry.hs
src/Generators/GenTypedFlatCurry.hs
+16
-11
src/Modules.hs
src/Modules.hs
+1
-1
No files found.
src/Generators/GenFlatCurry.hs
View file @
d7c80601
...
...
@@ -37,7 +37,7 @@ genFlatExpr :: TExpr -> Expr
genFlatExpr
=
trTExpr
(
const
Var
)
(
const
Lit
)
(
\
ct
name
args
->
Comb
ct
(
fst
name
)
args
)
(
\
_
ct
name
args
->
Comb
ct
name
args
)
(
\
bs
e
->
Let
(
map
(
\
(
v
,
e'
)
->
(
fst
v
,
e'
))
bs
)
e
)
(
\
vs
e
->
Free
(
map
fst
vs
)
e
)
Or
...
...
@@ -47,7 +47,7 @@ genFlatExpr = trTExpr
genFlatPattern
::
TPattern
->
Pattern
genFlatPattern
=
trTPattern
(
\
name
args
->
Pattern
(
fst
name
)
$
map
fst
args
)
(
\
_
name
args
->
Pattern
name
$
map
fst
args
)
(
const
LPattern
)
-- transforms a FlatCurry module to a FlatCurry interface
...
...
src/Generators/GenTypedFlatCurry.hs
View file @
d7c80601
...
...
@@ -371,9 +371,8 @@ trAlt (IL.Alt p e) = TBranch <$> trPat p <*> trTExpr e
-- Translate a pattern
trPat
::
IL
.
ConstrTerm
->
FlatState
TPattern
trPat
(
IL
.
LiteralPattern
ty
l
)
=
TLPattern
<$>
trType
ty
<*>
trLiteral
l
trPat
(
IL
.
ConstructorPattern
ty
c
vs
)
=
do
qty
<-
trType
$
foldr
(
IL
.
TypeArrow
.
fst
)
ty
vs
TPattern
<$>
((
\
q
->
(
q
,
qty
))
<$>
trQualIdent
c
)
<*>
mapM
(
uncurry
newVar
)
vs
trPat
(
IL
.
ConstructorPattern
ty
c
vs
)
=
TPattern
<$>
trType
ty
<*>
trQualIdent
c
<*>
mapM
(
uncurry
newVar
)
vs
trPat
(
IL
.
VariablePattern
_
_
)
=
internalError
"GenTypedFlatCurry.trPat"
-- Convert a case type
...
...
@@ -406,15 +405,19 @@ genCall call ty f es = do
genTComb
::
IL
.
Type
->
QName
->
[
IL
.
Expression
]
->
CombType
->
FlatState
TExpr
genTComb
ty
qid
es
ct
=
do
ty'
<-
trType
ty
TComb
ct
(
qid
,
ty'
)
<$>
mapM
trTExpr
es
let
ty''
=
defunc
ty'
(
length
es
)
TComb
ty''
ct
qid
<$>
mapM
trTExpr
es
where
defunc
t
0
=
t
defunc
(
FuncType
_
t2
)
n
=
defunc
t2
(
n
-
1
)
defunc
_
_
=
internalError
"GenTypedFlatCurry.genTComb.defunc"
genApply
::
TExpr
->
[
IL
.
Expression
]
->
FlatState
TExpr
genApply
e
es
=
do
ap
<-
trQualIdent
$
qApplyId
ap
<-
trQualIdent
qApplyId
es'
<-
mapM
trTExpr
es
return
$
foldl
(
\
e1
e2
->
let
FuncType
ty1
ty2
=
typeOf
e1
in
TComb
FuncCall
(
ap
,
FuncType
(
FuncType
ty1
ty2
)
(
FuncType
ty1
ty2
))
[
e1
,
e2
])
return
$
foldl
(
\
e1
e2
->
let
FuncType
_
ty2
=
typeOf
e1
in
TComb
ty2
FuncCall
ap
[
e1
,
e2
])
e
es'
-- -----------------------------------------------------------------------------
...
...
@@ -457,9 +460,10 @@ instance Normalize TRule where
normalize
(
TExternal
ty
s
)
=
flip
TExternal
s
<$>
normalize
ty
instance
Normalize
TExpr
where
normalize
(
TVarE
ty
v
)
=
flip
TVarE
v
<$>
normalize
ty
normalize
(
TVarE
ty
v
)
=
flip
TVarE
v
<$>
normalize
ty
normalize
(
TLit
ty
l
)
=
flip
TLit
l
<$>
normalize
ty
normalize
(
TComb
ct
f
es
)
=
TComb
ct
<$>
normalize
f
normalize
(
TComb
ty
ct
f
es
)
=
flip
TComb
ct
<$>
normalize
ty
<*>
pure
f
<*>
mapM
normalize
es
normalize
(
TLet
ds
e
)
=
TLet
<$>
mapM
normalizeBinding
ds
<*>
normalize
e
...
...
@@ -477,7 +481,8 @@ instance Normalize TBranchExpr where
normalize
(
TBranch
p
e
)
=
TBranch
<$>
normalize
p
<*>
normalize
e
instance
Normalize
TPattern
where
normalize
(
TPattern
c
vs
)
=
TPattern
<$>
normalize
c
normalize
(
TPattern
ty
c
vs
)
=
TPattern
<$>
normalize
ty
<*>
pure
c
<*>
mapM
normalize
vs
normalize
(
TLPattern
ty
l
)
=
flip
TLPattern
l
<$>
normalize
ty
...
...
src/Modules.hs
View file @
d7c80601
...
...
@@ -327,7 +327,7 @@ matchInterface ifn i = do
writeFlat
::
Options
->
CompilerEnv
->
CS
.
Module
Type
->
IL
.
Module
->
CYIO
()
writeFlat
opts
env
mdl
il
=
do
(
_
,
tfc
)
<-
dumpWith
opts
show
(
FC
.
ppProg
.
genFlatCurry
)
DumpTypedFlatCurry
(
env
,
tfcyProg
)
-- TODO ???
(
_
,
tfc
)
<-
dumpWith
opts
show
(
FC
.
ppProg
.
genFlatCurry
)
DumpTypedFlatCurry
(
env
,
tfcyProg
)
when
tfcyTarget
$
liftIO
$
FC
.
writeFlatCurry
(
useSubDir
tfcyName
)
tfc
when
tafcyTarget
$
liftIO
$
FC
.
writeFlatCurry
(
useSubDir
tafcyName
)
tafcyProg
when
fcyTarget
$
do
...
...
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