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
79782290
Commit
79782290
authored
Jun 10, 2018
by
Kai-Oliver Prott
Committed by
Finn Teegen
Jul 09, 2018
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Change TypedFlatCurry while keeping the old one as TypeAnnotatedFlat...
parent
242037ad
Changes
8
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
8 changed files
with
671 additions
and
153 deletions
+671
-153
curry-frontend.cabal
curry-frontend.cabal
+1
-0
src/CompilerOpts.hs
src/CompilerOpts.hs
+17
-14
src/CurryBuilder.hs
src/CurryBuilder.hs
+8
-7
src/Generators.hs
src/Generators.hs
+20
-12
src/Generators/GenFlatCurry.hs
src/Generators/GenFlatCurry.hs
+20
-20
src/Generators/GenTypeAnnotatedFlatCurry.hs
src/Generators/GenTypeAnnotatedFlatCurry.hs
+515
-0
src/Generators/GenTypedFlatCurry.hs
src/Generators/GenTypedFlatCurry.hs
+89
-99
src/Modules.hs
src/Modules.hs
+1
-1
No files found.
curry-frontend.cabal
View file @
79782290
...
...
@@ -108,6 +108,7 @@ Library
, Generators.GenAbstractCurry
, Generators.GenFlatCurry
, Generators.GenTypedFlatCurry
, Generators.GenTypeAnnotatedFlatCurry
, Html.CurryHtml
, Html.SyntaxColoring
, IL
...
...
src/CompilerOpts.hs
View file @
79782290
...
...
@@ -174,13 +174,14 @@ verbosities = [ ( VerbQuiet , "0", "quiet" )
-- |Type of the target file
data
TargetType
=
Tokens
-- ^ Source code tokens
|
Parsed
-- ^ Parsed source code
|
FlatCurry
-- ^ FlatCurry
|
TypedFlatCurry
-- ^ Typed FlatCurry
|
AbstractCurry
-- ^ AbstractCurry
|
UntypedAbstractCurry
-- ^ Untyped AbstractCurry
|
Html
-- ^ HTML documentation
=
Tokens
-- ^ Source code tokens
|
Parsed
-- ^ Parsed source code
|
FlatCurry
-- ^ FlatCurry
|
TypedFlatCurry
-- ^ Typed FlatCurry
|
TypeAnnotatedFlatCurry
-- ^ Type-annotated FlatCurry
|
AbstractCurry
-- ^ AbstractCurry
|
UntypedAbstractCurry
-- ^ Untyped AbstractCurry
|
Html
-- ^ HTML documentation
deriving
(
Eq
,
Show
)
-- |Warnings flags
...
...
@@ -421,19 +422,21 @@ options =
addFlag
WarnOverlapping
(
wnWarnFlags
opts
)
}))
"do not print warnings for overlapping rules"
-- target types
,
targetOption
Tokens
"tokens"
,
targetOption
Tokens
"tokens"
"generate token stream"
,
targetOption
Parsed
"parse-only"
,
targetOption
Parsed
"parse-only"
"generate source representation"
,
targetOption
FlatCurry
"flat"
,
targetOption
FlatCurry
"flat"
"generate FlatCurry code"
,
targetOption
TypedFlatCurry
"typed-flat"
,
targetOption
TypedFlatCurry
"typed-flat"
"generate typed FlatCurry code"
,
targetOption
AbstractCurry
"acy"
,
targetOption
TypeAnnotatedFlatCurry
"typed-flat"
"generate type-annotated FlatCurry code"
,
targetOption
AbstractCurry
"acy"
"generate typed AbstractCurry"
,
targetOption
UntypedAbstractCurry
"uacy"
,
targetOption
UntypedAbstractCurry
"uacy"
"generate untyped AbstractCurry"
,
targetOption
Html
"html"
,
targetOption
Html
"html"
"generate html documentation"
,
Option
"F"
[]
(
NoArg
(
onPrepOpts
$
\
opts
->
opts
{
ppPreprocess
=
True
}))
...
...
src/CurryBuilder.hs
View file @
79782290
...
...
@@ -165,13 +165,14 @@ process opts idx m fn deps
destFiles
=
[
gen
fn
|
(
t
,
gen
)
<-
nameGens
,
t
`
elem
`
optTargetTypes
opts
]
nameGens
=
[
(
Tokens
,
tgtDir
.
tokensName
)
,
(
Parsed
,
tgtDir
.
sourceRepName
)
,
(
FlatCurry
,
tgtDir
.
flatName
)
,
(
TypedFlatCurry
,
tgtDir
.
typedFlatName
)
,
(
AbstractCurry
,
tgtDir
.
acyName
)
,
(
UntypedAbstractCurry
,
tgtDir
.
uacyName
)
,
(
Html
,
const
(
fromMaybe
"."
(
optHtmlDir
opts
)
</>
htmlName
m
))
[
(
Tokens
,
tgtDir
.
tokensName
)
,
(
Parsed
,
tgtDir
.
sourceRepName
)
,
(
FlatCurry
,
tgtDir
.
flatName
)
,
(
TypedFlatCurry
,
tgtDir
.
typedFlatName
)
,
(
TypeAnnotatedFlatCurry
,
tgtDir
.
typeAnnFlatName
)
,
(
AbstractCurry
,
tgtDir
.
acyName
)
,
(
UntypedAbstractCurry
,
tgtDir
.
uacyName
)
,
(
Html
,
const
(
fromMaybe
"."
(
optHtmlDir
opts
)
</>
htmlName
m
))
]
-- |Create a status message like
...
...
src/Generators.hs
View file @
79782290
...
...
@@ -13,16 +13,19 @@
-}
module
Generators
where
import
qualified
Curry.AbstractCurry
as
AC
(
CurryProg
)
import
qualified
Curry.FlatCurry.Type
as
FC
(
Prog
)
import
qualified
Curry.FlatCurry.Annotated.Type
as
AFC
(
AProg
,
TypeExpr
)
import
qualified
Curry.Syntax
as
CS
(
Module
)
import
qualified
Generators.GenAbstractCurry
as
GAC
(
genAbstractCurry
)
import
qualified
Generators.GenFlatCurry
as
GFC
(
genFlatCurry
,
genFlatInterface
)
import
qualified
Generators.GenTypedFlatCurry
as
GTFC
(
genTypedFlatCurry
)
import
qualified
Curry.AbstractCurry
as
AC
(
CurryProg
)
import
qualified
Curry.FlatCurry.Type
as
FC
(
Prog
,
TypeExpr
)
import
qualified
Curry.FlatCurry.Annotated.Type
as
AFC
(
AProg
)
import
qualified
Curry.FlatCurry.Typed.Type
as
TFC
(
TProg
)
import
qualified
Curry.Syntax
as
CS
(
Module
)
import
qualified
Generators.GenAbstractCurry
as
GAC
(
genAbstractCurry
)
import
qualified
Generators.GenFlatCurry
as
GFC
(
genFlatCurry
,
genFlatInterface
)
import
qualified
Generators.GenTypeAnnotatedFlatCurry
as
GTAFC
(
genTypeAnnotatedFlatCurry
)
import
qualified
Generators.GenTypedFlatCurry
as
GTFC
(
genTypedFlatCurry
)
import
Base.Types
(
Type
,
PredType
)
...
...
@@ -39,11 +42,16 @@ genUntypedAbstractCurry = GAC.genAbstractCurry True
-- |Generate typed FlatCurry
genTypedFlatCurry
::
CompilerEnv
->
CS
.
Module
Type
->
IL
.
Module
->
A
FC
.
A
Prog
AFC
.
TypeExpr
->
T
FC
.
T
Prog
genTypedFlatCurry
=
GTFC
.
genTypedFlatCurry
-- |Generate type-annotated FlatCurry
genTypeAnnotatedFlatCurry
::
CompilerEnv
->
CS
.
Module
Type
->
IL
.
Module
->
AFC
.
AProg
FC
.
TypeExpr
genTypeAnnotatedFlatCurry
=
GTAFC
.
genTypeAnnotatedFlatCurry
-- |Generate FlatCurry
genFlatCurry
::
A
FC
.
A
Prog
a
->
FC
.
Prog
genFlatCurry
::
T
FC
.
T
Prog
->
FC
.
Prog
genFlatCurry
=
GFC
.
genFlatCurry
-- |Generate a FlatCurry interface
...
...
src/Generators/GenFlatCurry.hs
View file @
79782290
...
...
@@ -15,39 +15,39 @@ module Generators.GenFlatCurry (genFlatCurry, genFlatInterface) where
import
Curry.FlatCurry.Goodies
import
Curry.FlatCurry.Type
import
Curry.FlatCurry.
Annotat
ed.Goodies
import
Curry.FlatCurry.
Annotat
ed.Type
import
Curry.FlatCurry.
Typ
ed.Goodies
import
Curry.FlatCurry.
Typ
ed.Type
-- transforms annotated FlatCurry code to FlatCurry code
genFlatCurry
::
A
Prog
a
->
Prog
genFlatCurry
=
tr
A
Prog
genFlatCurry
::
T
Prog
->
Prog
genFlatCurry
=
tr
T
Prog
(
\
name
imps
types
funcs
ops
->
Prog
name
imps
types
(
map
genFlatFuncDecl
funcs
)
ops
)
genFlatFuncDecl
::
A
FuncDecl
a
->
FuncDecl
genFlatFuncDecl
=
tr
A
Func
genFlatFuncDecl
::
T
FuncDecl
->
FuncDecl
genFlatFuncDecl
=
tr
T
Func
(
\
name
arity
vis
ty
rule
->
Func
name
arity
vis
ty
$
genFlatRule
rule
)
genFlatRule
::
A
Rule
a
->
Rule
genFlatRule
=
tr
A
Rule
(
\
_
args
e
->
Rule
(
map
fst
args
)
$
genFlatExpr
e
)
genFlatRule
::
T
Rule
->
Rule
genFlatRule
=
tr
T
Rule
(
\
args
e
->
Rule
(
map
fst
args
)
$
genFlatExpr
e
)
(
const
External
)
genFlatExpr
::
A
Expr
a
->
Expr
genFlatExpr
=
tr
A
Expr
genFlatExpr
::
T
Expr
->
Expr
genFlatExpr
=
tr
T
Expr
(
const
Var
)
(
const
Lit
)
(
\
_
ct
name
args
->
Comb
ct
(
fst
name
)
args
)
(
\
_
bs
e
->
Let
(
map
(
\
(
v
,
e'
)
->
(
fst
v
,
e'
))
bs
)
e
)
(
\
_
vs
e
->
Free
(
map
fst
vs
)
e
)
(
\
_
e1
e2
->
Or
e1
e2
)
(
\
_
ct
e
bs
->
Case
ct
e
bs
)
(
\
ct
name
args
->
Comb
ct
(
fst
name
)
args
)
(
\
bs
e
->
Let
(
map
(
\
(
v
,
e'
)
->
(
fst
v
,
e'
))
bs
)
e
)
(
\
vs
e
->
Free
(
map
fst
vs
)
e
)
Or
Case
(
\
pat
e
->
Branch
(
genFlatPattern
pat
)
e
)
(
\
_
e
ty
->
Typed
e
ty
)
Typed
genFlatPattern
::
A
Pattern
a
->
Pattern
genFlatPattern
=
tr
A
Pattern
(
\
_
name
args
->
Pattern
(
fst
name
)
$
map
fst
args
)
genFlatPattern
::
T
Pattern
->
Pattern
genFlatPattern
=
tr
T
Pattern
(
\
name
args
->
Pattern
(
fst
name
)
$
map
fst
args
)
(
const
LPattern
)
-- transforms a FlatCurry module to a FlatCurry interface
...
...
src/Generators/GenTypeAnnotatedFlatCurry.hs
0 → 100644
View file @
79782290
This diff is collapsed.
Click to expand it.
src/Generators/GenTypedFlatCurry.hs
View file @
79782290
...
...
@@ -28,9 +28,8 @@ import qualified Data.Map as Map (Map, empty, insert, lookup)
import
qualified
Data.Set
as
Set
(
Set
,
empty
,
insert
,
member
)
import
Curry.Base.Ident
import
Curry.FlatCurry.Annotated.Goodies
(
typeName
)
import
Curry.FlatCurry.Annotated.Type
import
Curry.FlatCurry.Annotated.Typing
import
Curry.FlatCurry.Typed.Goodies
(
typeName
)
import
Curry.FlatCurry.Typed.Type
import
qualified
Curry.Syntax
as
CS
import
Base.CurryTypes
(
toType
)
...
...
@@ -45,21 +44,21 @@ import Env.OpPrec (mkPrec)
import
Env.TypeConstructor
(
TCEnv
)
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
),
qualLookupValue
)
import
qualified
IL
as
IL
import
qualified
IL
import
Transformations
(
transType
)
-- transforms intermediate language code (IL) to typed FlatCurry code
genTypedFlatCurry
::
CompilerEnv
->
CS
.
Module
Type
->
IL
.
Module
->
A
Prog
TypeExpr
->
T
Prog
genTypedFlatCurry
env
mdl
il
=
patchPrelude
$
run
env
mdl
(
trModule
il
)
-- -----------------------------------------------------------------------------
-- Addition of primitive types for lists and tuples to the Prelude
-- -----------------------------------------------------------------------------
patchPrelude
::
A
Prog
a
->
A
Prog
a
patchPrelude
p
@
(
A
Prog
n
_
ts
fs
os
)
|
n
==
prelude
=
A
Prog
n
[]
ts'
fs
os
patchPrelude
::
T
Prog
->
T
Prog
patchPrelude
p
@
(
T
Prog
n
_
ts
fs
os
)
|
n
==
prelude
=
T
Prog
n
[]
ts'
fs
os
|
otherwise
=
p
where
ts'
=
sortBy
(
compare
`
on
`
typeName
)
pts
pts
=
primTypes
++
ts
...
...
@@ -222,14 +221,14 @@ trIOpDecl _ = return []
-- Translation of a module
-- -----------------------------------------------------------------------------
trModule
::
IL
.
Module
->
FlatState
(
A
Prog
TypeExpr
)
trModule
::
IL
.
Module
->
FlatState
T
Prog
trModule
(
IL
.
Module
mid
is
ds
)
=
do
is'
<-
getImports
is
sns
<-
getTypeSynonyms
>>=
concatMapM
trTypeSynonym
tds
<-
concatMapM
trTypeDecl
ds
fds
<-
concatMapM
(
return
.
map
runNormalization
<=<
tr
A
FuncDecl
)
ds
fds
<-
concatMapM
(
return
.
map
runNormalization
<=<
tr
T
FuncDecl
)
ds
ops
<-
getFixities
>>=
concatMapM
trIOpDecl
return
$
A
Prog
(
moduleName
mid
)
is'
(
sns
++
tds
)
fds
ops
return
$
T
Prog
(
moduleName
mid
)
is'
(
sns
++
tds
)
fds
ops
-- Translate a type synonym
trTypeSynonym
::
CS
.
Decl
a
->
FlatState
[
TypeDecl
]
...
...
@@ -291,64 +290,60 @@ cvFixity CS.Infix = InfixOp
-- -----------------------------------------------------------------------------
-- Translate a function declaration
tr
A
FuncDecl
::
IL
.
Decl
->
FlatState
[
A
FuncDecl
TypeExpr
]
tr
A
FuncDecl
(
IL
.
FunctionDecl
f
vs
_
e
)
=
do
tr
T
FuncDecl
::
IL
.
Decl
->
FlatState
[
T
FuncDecl
]
tr
T
FuncDecl
(
IL
.
FunctionDecl
f
vs
_
e
)
=
do
f'
<-
trQualIdent
f
a
<-
getArity
f
vis
<-
getVisibility
f
ty'
<-
trType
ty
r'
<-
tr
A
Rule
ty
vs
e
return
[
A
Func
f'
a
vis
ty'
r'
]
r'
<-
tr
T
Rule
vs
e
return
[
T
Func
f'
a
vis
ty'
r'
]
where
ty
=
foldr
IL
.
TypeArrow
(
IL
.
typeOf
e
)
$
map
fst
vs
tr
A
FuncDecl
(
IL
.
ExternalDecl
f
ty
)
=
do
tr
T
FuncDecl
(
IL
.
ExternalDecl
f
ty
)
=
do
f'
<-
trQualIdent
f
a
<-
getArity
f
vis
<-
getVisibility
f
ty'
<-
trType
ty
r'
<-
tr
A
External
ty
f
return
[
A
Func
f'
a
vis
ty'
r'
]
tr
A
FuncDecl
_
=
return
[]
r'
<-
tr
T
External
ty
f
return
[
T
Func
f'
a
vis
ty'
r'
]
tr
T
FuncDecl
_
=
return
[]
-- Translate a function rule.
-- Resets variable index so that for every rule variables start with index 1
trARule
::
IL
.
Type
->
[(
IL
.
Type
,
Ident
)]
->
IL
.
Expression
->
FlatState
(
ARule
TypeExpr
)
trARule
ty
vs
e
=
withFreshEnv
$
ARule
<$>
trType
ty
<*>
mapM
(
uncurry
newVar
)
vs
<*>
trAExpr
e
trTRule
::
[(
IL
.
Type
,
Ident
)]
->
IL
.
Expression
->
FlatState
TRule
trTRule
vs
e
=
withFreshEnv
$
TRule
<$>
mapM
(
uncurry
newVar
)
vs
<*>
trTExpr
e
tr
A
External
::
IL
.
Type
->
QualIdent
->
FlatState
(
A
Rule
TypeExpr
)
tr
A
External
ty
f
=
flip
A
External
(
qualName
f
)
<$>
trType
ty
tr
T
External
::
IL
.
Type
->
QualIdent
->
FlatState
T
Rule
tr
T
External
ty
f
=
flip
T
External
(
qualName
f
)
<$>
trType
ty
-- Translate an expression
tr
A
Expr
::
IL
.
Expression
->
FlatState
(
AExpr
Type
Expr
)
tr
A
Expr
(
IL
.
Literal
ty
l
)
=
A
Lit
<$>
trType
ty
<*>
trLiteral
l
tr
A
Expr
(
IL
.
Variable
ty
v
)
=
A
Var
<$>
trType
ty
<*>
getVarIndex
v
tr
A
Expr
(
IL
.
Function
ty
f
_
)
=
genCall
Fun
ty
f
[]
tr
A
Expr
(
IL
.
Constructor
ty
c
_
)
=
genCall
Con
ty
c
[]
tr
A
Expr
(
IL
.
Apply
e1
e2
)
=
trApply
e1
e2
tr
A
Expr
c
@
(
IL
.
Case
t
e
bs
)
=
flip
A
Case
(
cvEval
t
)
<$>
trT
ype
(
IL
.
typeOf
c
)
<*>
trA
Expr
e
tr
T
Expr
::
IL
.
Expression
->
FlatState
T
Expr
tr
T
Expr
(
IL
.
Literal
ty
l
)
=
T
Lit
<$>
trType
ty
<*>
trLiteral
l
tr
T
Expr
(
IL
.
Variable
ty
v
)
=
T
Var
E
<$>
trType
ty
<*>
getVarIndex
v
tr
T
Expr
(
IL
.
Function
ty
f
_
)
=
genCall
Fun
ty
f
[]
tr
T
Expr
(
IL
.
Constructor
ty
c
_
)
=
genCall
Con
ty
c
[]
tr
T
Expr
(
IL
.
Apply
e1
e2
)
=
trApply
e1
e2
tr
T
Expr
(
IL
.
Case
t
e
bs
)
=
T
Case
(
cvEval
t
)
<$>
trTExpr
e
<*>
mapM
(
inNestedEnv
.
trAlt
)
bs
tr
A
Expr
(
IL
.
Or
e1
e2
)
=
A
Or
<$>
trT
ype
(
IL
.
typeOf
e1
)
<*>
trA
Expr
e1
<*>
tr
A
Expr
e2
tr
A
Expr
(
IL
.
Exist
v
ty
e
)
=
inNestedEnv
$
do
tr
T
Expr
(
IL
.
Or
e1
e2
)
=
T
Or
<$>
trTExpr
e1
<*>
tr
T
Expr
e2
tr
T
Expr
(
IL
.
Exist
v
ty
e
)
=
inNestedEnv
$
do
v'
<-
newVar
ty
v
e'
<-
trAExpr
e
ty'
<-
trType
(
IL
.
typeOf
e
)
return
$
case
e'
of
AFree
ty''
vs
e''
->
AFree
ty''
(
v'
:
vs
)
e''
_
->
AFree
ty'
(
v'
:
[]
)
e'
trAExpr
(
IL
.
Let
(
IL
.
Binding
v
b
)
e
)
=
inNestedEnv
$
do
e'
<-
trTExpr
e
return
$
case
e'
of
TFree
vs
e''
->
TFree
(
v'
:
vs
)
e''
_
->
TFree
(
v'
:
[]
)
e'
trTExpr
(
IL
.
Let
(
IL
.
Binding
v
b
)
e
)
=
inNestedEnv
$
do
v'
<-
newVar
(
IL
.
typeOf
b
)
v
b'
<-
trAExpr
b
e'
<-
trAExpr
e
ty'
<-
trType
$
IL
.
typeOf
e
return
$
case
e'
of
ALet
ty''
bs
e''
->
ALet
ty''
((
v'
,
b'
)
:
bs
)
e''
_
->
ALet
ty'
((
v'
,
b'
)
:
[]
)
e'
trAExpr
(
IL
.
Letrec
bs
e
)
=
inNestedEnv
$
do
b'
<-
trTExpr
b
e'
<-
trTExpr
e
return
$
case
e'
of
TLet
bs
e''
->
TLet
((
v'
,
b'
)
:
bs
)
e''
_
->
TLet
((
v'
,
b'
)
:
[]
)
e'
trTExpr
(
IL
.
Letrec
bs
e
)
=
inNestedEnv
$
do
let
(
vs
,
es
)
=
unzip
[
((
IL
.
typeOf
b
,
v
),
b
)
|
IL
.
Binding
v
b
<-
bs
]
ALet
<$>
trType
(
IL
.
typeOf
e
)
<*>
(
zip
<$>
mapM
(
uncurry
newVar
)
vs
<*>
mapM
trAExpr
es
)
<*>
trAExpr
e
trAExpr
(
IL
.
Typed
e
_
)
=
ATyped
<$>
ty'
<*>
trAExpr
e
<*>
ty'
TLet
<$>
(
zip
<$>
mapM
(
uncurry
newVar
)
vs
<*>
mapM
trTExpr
es
)
<*>
trTExpr
e
trTExpr
(
IL
.
Typed
e
_
)
=
TTyped
<$>
trTExpr
e
<*>
ty'
where
ty'
=
trType
$
IL
.
typeOf
e
-- Translate a literal
...
...
@@ -358,7 +353,7 @@ trLiteral (IL.Int i) = return $ Intc i
trLiteral
(
IL
.
Float
f
)
=
return
$
Floatc
f
-- Translate a higher-order application
trApply
::
IL
.
Expression
->
IL
.
Expression
->
FlatState
(
AExpr
Type
Expr
)
trApply
::
IL
.
Expression
->
IL
.
Expression
->
FlatState
T
Expr
trApply
e1
e2
=
genFlatApplic
e1
[
e2
]
where
genFlatApplic
e
es
=
case
e
of
...
...
@@ -366,19 +361,19 @@ trApply e1 e2 = genFlatApplic e1 [e2]
IL
.
Function
ty
f
_
->
genCall
Fun
ty
f
es
IL
.
Constructor
ty
c
_
->
genCall
Con
ty
c
es
_
->
do
expr
<-
tr
A
Expr
e
expr
<-
tr
T
Expr
e
genApply
expr
es
-- Translate an alternative
trAlt
::
IL
.
Alt
->
FlatState
(
A
BranchExpr
TypeExpr
)
trAlt
(
IL
.
Alt
p
e
)
=
A
Branch
<$>
trPat
p
<*>
tr
A
Expr
e
trAlt
::
IL
.
Alt
->
FlatState
T
BranchExpr
trAlt
(
IL
.
Alt
p
e
)
=
T
Branch
<$>
trPat
p
<*>
tr
T
Expr
e
-- Translate a pattern
trPat
::
IL
.
ConstrTerm
->
FlatState
(
A
Pattern
TypeExpr
)
trPat
(
IL
.
LiteralPattern
ty
l
)
=
A
LPattern
<$>
trType
ty
<*>
trLiteral
l
trPat
::
IL
.
ConstrTerm
->
FlatState
T
Pattern
trPat
(
IL
.
LiteralPattern
ty
l
)
=
T
LPattern
<$>
trType
ty
<*>
trLiteral
l
trPat
(
IL
.
ConstructorPattern
ty
c
vs
)
=
do
qty
<-
trType
$
foldr
IL
.
TypeArrow
ty
$
map
fst
vs
A
Pattern
<$>
trType
ty
<*>
((
\
q
->
(
q
,
qty
))
<$>
trQualIdent
c
)
<*>
mapM
(
uncurry
newVar
)
vs
qty
<-
trType
$
foldr
(
IL
.
TypeArrow
.
fst
)
ty
vs
T
Pattern
<$>
((
\
q
->
(
q
,
qty
))
<$>
trQualIdent
c
)
<*>
mapM
(
uncurry
newVar
)
vs
trPat
(
IL
.
VariablePattern
_
_
)
=
internalError
"GenTypedFlatCurry.trPat"
-- Convert a case type
...
...
@@ -390,16 +385,16 @@ data Call = Fun | Con
-- Generate a function or constructor call
genCall
::
Call
->
IL
.
Type
->
QualIdent
->
[
IL
.
Expression
]
->
FlatState
(
AExpr
Type
Expr
)
->
FlatState
T
Expr
genCall
call
ty
f
es
=
do
f'
<-
trQualIdent
f
arity
<-
getArity
f
case
compare
supplied
arity
of
LT
->
gen
A
Comb
ty
f'
es
(
part
call
(
arity
-
supplied
))
EQ
->
gen
A
Comb
ty
f'
es
(
full
call
)
LT
->
gen
T
Comb
ty
f'
es
(
part
call
(
arity
-
supplied
))
EQ
->
gen
T
Comb
ty
f'
es
(
full
call
)
GT
->
do
let
(
es1
,
es2
)
=
splitAt
arity
es
funccall
<-
gen
A
Comb
ty
f'
es1
(
full
call
)
funccall
<-
gen
T
Comb
ty
f'
es1
(
full
call
)
genApply
funccall
es2
where
supplied
=
length
es
...
...
@@ -408,21 +403,19 @@ genCall call ty f es = do
part
Fun
=
FuncPartCall
part
Con
=
ConsPartCall
gen
A
Comb
::
IL
.
Type
->
QName
->
[
IL
.
Expression
]
->
CombType
->
FlatState
(
AExpr
Type
Expr
)
gen
A
Comb
ty
qid
es
ct
=
do
gen
T
Comb
::
IL
.
Type
->
QName
->
[
IL
.
Expression
]
->
CombType
->
FlatState
T
Expr
gen
T
Comb
ty
qid
es
ct
=
do
ty'
<-
trType
ty
let
ty''
=
defunc
ty'
(
length
es
)
AComb
ty''
ct
(
qid
,
ty'
)
<$>
mapM
trAExpr
es
where
defunc
t
0
=
t
defunc
(
FuncType
_
t2
)
n
=
defunc
t2
(
n
-
1
)
defunc
_
_
=
internalError
"GenTypedFlatCurry.genAComb.defunc"
TComb
ct
(
qid
,
ty'
)
<$>
mapM
trTExpr
es
genApply
::
AExpr
Type
Expr
->
[
IL
.
Expression
]
->
FlatState
(
AExpr
Type
Expr
)
genApply
::
T
Expr
->
[
IL
.
Expression
]
->
FlatState
T
Expr
genApply
e
es
=
do
ap
<-
trQualIdent
$
qApplyId
es'
<-
mapM
trAExpr
es
return
$
foldl
(
\
e1
e2
->
let
FuncType
ty1
ty2
=
typeOf
e1
in
AComb
ty2
FuncCall
(
ap
,
FuncType
(
FuncType
ty1
ty2
)
(
FuncType
ty1
ty2
))
[
e1
,
e2
])
e
es'
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
])
e
es'
-- -----------------------------------------------------------------------------
-- Normalization
...
...
@@ -453,43 +446,40 @@ instance Normalize TypeExpr where
ForallType
<$>
mapM
normalize
is
<*>
normalize
ty
instance
Normalize
b
=>
Normalize
(
a
,
b
)
where
normalize
(
x
,
y
)
=
(
(,)
x
)
<$>
normalize
y
normalize
(
x
,
y
)
=
(,)
x
<$>
normalize
y
instance
Normalize
a
=>
Normalize
(
A
FuncDecl
a
)
where
normalize
(
A
Func
f
a
v
ty
r
)
=
A
Func
f
a
v
<$>
normalize
ty
<*>
normalize
r
instance
Normalize
T
FuncDecl
where
normalize
(
T
Func
f
a
v
ty
r
)
=
T
Func
f
a
v
<$>
normalize
ty
<*>
normalize
r
instance
Normalize
a
=>
Normalize
(
ARule
a
)
where
normalize
(
ARule
ty
vs
e
)
=
ARule
<$>
normalize
ty
<*>
mapM
normalize
vs
instance
Normalize
TRule
where
normalize
(
TRule
vs
e
)
=
TRule
<$>
mapM
normalize
vs
<*>
normalize
e
normalize
(
AExternal
ty
s
)
=
flip
AExternal
s
<$>
normalize
ty
instance
Normalize
a
=>
Normalize
(
AExpr
a
)
where
normalize
(
AVar
ty
v
)
=
flip
AVar
v
<$>
normalize
ty
normalize
(
ALit
ty
l
)
=
flip
ALit
l
<$>
normalize
ty
normalize
(
AComb
ty
ct
f
es
)
=
flip
AComb
ct
<$>
normalize
ty
<*>
normalize
f
<*>
mapM
normalize
es
normalize
(
ALet
ty
ds
e
)
=
ALet
<$>
normalize
ty
<*>
mapM
normalizeBinding
ds
normalize
(
TExternal
ty
s
)
=
flip
TExternal
s
<$>
normalize
ty
instance
Normalize
TExpr
where
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
<*>
mapM
normalize
es
normalize
(
TLet
ds
e
)
=
TLet
<$>
mapM
normalizeBinding
ds
<*>
normalize
e
where
normalizeBinding
(
v
,
b
)
=
(,)
<$>
normalize
v
<*>
normalize
b
normalize
(
A
Or
ty
a
b
)
=
A
Or
<$>
normalize
ty
<*>
normalize
a
normalize
(
T
Or
a
b
)
=
T
Or
<$>
normalize
a
<*>
normalize
b
normalize
(
A
Case
ty
ct
e
bs
)
=
flip
A
Case
ct
<$>
normalize
ty
<*>
normalize
e
<*>
mapM
normalize
bs
normalize
(
A
Free
ty
vs
e
)
=
A
Free
<$>
normalize
ty
<*>
mapM
normalize
vs
normalize
(
T
Case
ct
e
bs
)
=
T
Case
ct
<$>
normalize
e
<*>
mapM
normalize
bs
normalize
(
T
Free
vs
e
)
=
T
Free
<$>
mapM
normalize
vs
<*>
normalize
e
normalize
(
A
Typed
ty
e
ty'
)
=
A
Typed
<$>
normalize
ty
<*>
normalize
e
normalize
(
T
Typed
e
ty'
)
=
T
Typed
<$>
normalize
e
<*>
normalize
ty'
instance
Normalize
a
=>
Normalize
(
A
BranchExpr
a
)
where
normalize
(
A
Branch
p
e
)
=
A
Branch
<$>
normalize
p
<*>
normalize
e
instance
Normalize
T
BranchExpr
where
normalize
(
T
Branch
p
e
)
=
T
Branch
<$>
normalize
p
<*>
normalize
e
instance
Normalize
a
=>
Normalize
(
A
Pattern
a
)
where
normalize
(
A
Pattern
ty
c
vs
)
=
A
Pattern
<$>
normalize
ty
<*>
normalize
c
instance
Normalize
T
Pattern
where
normalize
(
T
Pattern
c
vs
)
=
T
Pattern
<$>
normalize
c
<*>
mapM
normalize
vs
normalize
(
A
LPattern
ty
l
)
=
flip
A
LPattern
l
<$>
normalize
ty
normalize
(
T
LPattern
ty
l
)
=
flip
T
LPattern
l
<$>
normalize
ty
-- -----------------------------------------------------------------------------
-- Helper functions
...
...
src/Modules.hs
View file @
79782290
...
...
@@ -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
)
(
_
,
tfc
)
<-
dumpWith
opts
show
(
FC
.
ppProg
.
genFlatCurry
)
DumpTypedFlatCurry
(
env
,
tfcyProg
)
-- TODO ???
when
tfcyTarget
$
liftIO
$
FC
.
writeFlatCurry
(
useSubDir
tfcyName
)
tfc
when
fcyTarget
$
do
(
_
,
fc
)
<-
dumpWith
opts
show
FC
.
ppProg
DumpFlatCurry
(
env
,
fcyProg
)
...
...
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