Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
GHC
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
4,323
Issues
4,323
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
376
Merge Requests
376
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
4d5f83a8
Commit
4d5f83a8
authored
Dec 03, 2014
by
Austin Seipp
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
compiler: de-lhs deSugar/
Signed-off-by:
Austin Seipp
<
austin@well-typed.com
>
parent
b57ff272
Changes
18
Hide whitespace changes
Inline
Side-by-side
Showing
18 changed files
with
523 additions
and
640 deletions
+523
-640
compiler/deSugar/Check.hs
compiler/deSugar/Check.hs
+36
-44
compiler/deSugar/Coverage.hs
compiler/deSugar/Coverage.hs
+21
-31
compiler/deSugar/Desugar.hs
compiler/deSugar/Desugar.hs
+36
-41
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsArrows.hs
+27
-47
compiler/deSugar/DsBinds.hs
compiler/deSugar/DsBinds.hs
+31
-33
compiler/deSugar/DsCCall.hs
compiler/deSugar/DsCCall.hs
+7
-13
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsExpr.hs
+81
-94
compiler/deSugar/DsExpr.hs-boot
compiler/deSugar/DsExpr.hs-boot
+0
-2
compiler/deSugar/DsForeign.hs
compiler/deSugar/DsForeign.hs
+39
-44
compiler/deSugar/DsGRHSs.hs
compiler/deSugar/DsGRHSs.hs
+18
-20
compiler/deSugar/DsListComp.hs
compiler/deSugar/DsListComp.hs
+33
-42
compiler/deSugar/DsMonad.hs
compiler/deSugar/DsMonad.hs
+44
-57
compiler/deSugar/DsMonad.hs-boot
compiler/deSugar/DsMonad.hs-boot
+2
-3
compiler/deSugar/DsUtils.hs
compiler/deSugar/DsUtils.hs
+43
-51
compiler/deSugar/Match.hs
compiler/deSugar/Match.hs
+52
-57
compiler/deSugar/Match.hs-boot
compiler/deSugar/Match.hs-boot
+0
-2
compiler/deSugar/MatchCon.hs
compiler/deSugar/MatchCon.hs
+10
-9
compiler/deSugar/MatchLit.hs
compiler/deSugar/MatchLit.hs
+43
-50
No files found.
compiler/deSugar/Check.
l
hs
→
compiler/deSugar/Check.hs
View file @
4d5f83a8
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
%
% Author: Juan J. Quintela <quintela@krilin.dc.fi.udc.es>
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1997-1998
Author: Juan J. Quintela <quintela@krilin.dc.fi.udc.es>
-}
\begin{code}
{-# LANGUAGE CPP #-}
module
Check
(
check
,
ExhaustivePat
)
where
...
...
@@ -29,8 +29,8 @@ import Util
import
BasicTypes
import
Outputable
import
FastString
\end{code}
{-
This module performs checks about if one list of equations are:
\begin{itemize}
\item Overlapped
...
...
@@ -95,8 +95,8 @@ Then we need to use InPats.
Juan Quintela 5 JUL 1998\\
User-friendliness and compiler writers are no friends.
\end{quotation}
-}
\begin{code}
type
WarningPat
=
InPat
Name
type
ExhaustivePat
=
([
WarningPat
],
[(
Name
,
[
HsLit
])])
type
EqnNo
=
Int
...
...
@@ -122,11 +122,8 @@ untidy_exhaustive (pats, messages) =
untidy_message
::
(
Name
,
[
HsLit
])
->
(
Name
,
[
HsLit
])
untidy_message
(
string
,
lits
)
=
(
string
,
map
untidy_lit
lits
)
\end{code}
The function @untidy@ does the reverse work of the @tidy_pat@ function.
\begin{code}
-- The function @untidy@ does the reverse work of the @tidy_pat@ function.
type
NeedPars
=
Bool
...
...
@@ -144,9 +141,9 @@ untidy b (L loc p) = L loc (untidy' b p)
untidy'
_
(
LitPat
lit
)
=
LitPat
(
untidy_lit
lit
)
untidy'
_
p
@
(
ConPatIn
_
(
PrefixCon
[]
))
=
p
untidy'
b
(
ConPatIn
name
ps
)
=
pars
b
(
L
loc
(
ConPatIn
name
(
untidy_con
ps
)))
untidy' _ (ListPat pats ty Nothing) = ListPat (map untidy_no_pars pats) ty Nothing
untidy'
_
(
ListPat
pats
ty
Nothing
)
=
ListPat
(
map
untidy_no_pars
pats
)
ty
Nothing
untidy'
_
(
TuplePat
pats
box
tys
)
=
TuplePat
(
map
untidy_no_pars
pats
)
box
tys
untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat"
untidy'
_
(
ListPat
_
_
(
Just
_
))
=
panic
"Check.untidy: Overloaded ListPat"
untidy'
_
(
PArrPat
_
_
)
=
panic
"Check.untidy: Shouldn't get a parallel array here!"
untidy'
_
(
SigPatIn
_
_
)
=
panic
"Check.untidy: SigPat"
untidy'
_
(
LazyPat
{})
=
panic
"Check.untidy: LazyPat"
...
...
@@ -177,8 +174,8 @@ pars _ p = unLoc p
untidy_lit
::
HsLit
->
HsLit
untidy_lit
(
HsCharPrim
src
c
)
=
HsChar
src
c
untidy_lit
lit
=
lit
\end{code}
{-
This equation is the same that check, the only difference is that the
boring work is done, that work needs to be done only once, this is
the reason top have two functions, check is the external interface,
...
...
@@ -203,9 +200,7 @@ There are several cases:
vars in the first column, we actuate in consequence.
\end{itemize}
\begin{code}
-}
check'
::
[(
EqnNo
,
EquationInfo
)]
->
([
ExhaustivePat
],
-- Pattern scheme that might not be matched at all
...
...
@@ -213,7 +208,7 @@ check' :: [(EqnNo, EquationInfo)]
check'
[]
=
(
[]
,
emptyUniqSet
)
-- Was ([([],[])], emptyUniqSet)
-- But that (a) seems weird, and (b) triggered Trac #7669
-- But that (a) seems weird, and (b) triggered Trac #7669
-- So now I'm just doing the simple obvious thing
check'
((
n
,
EqnInfo
{
eqn_pats
=
ps
,
eqn_rhs
=
MatchResult
can_fail
_
})
:
rs
)
...
...
@@ -242,36 +237,34 @@ check' qs
some_constructors
=
any
is_con
first_pats
some_literals
=
any
is_lit
first_pats
only_vars
=
all
is_var
first_pats
\end{code}
{-
Here begins the code to deal with literals, we need to split the matrix
in different matrix beginning by each literal and a last matrix with the
rest of values.
-}
\begin{code}
split_by_literals
::
[(
EqnNo
,
EquationInfo
)]
->
([
ExhaustivePat
],
EqnSet
)
split_by_literals
qs
=
process_literals
used_lits
qs
where
used_lits
=
get_used_lits
qs
\end{code}
{-
@process_explicit_literals@ is a function that process each literal that appears
in the column of the matrix.
-}
\begin{code}
process_explicit_literals
::
[
HsLit
]
->
[(
EqnNo
,
EquationInfo
)]
->
([
ExhaustivePat
],
EqnSet
)
process_explicit_literals
lits
qs
=
(
concat
pats
,
unionManyUniqSets
indexs
)
where
pats_indexs
=
map
(
\
x
->
construct_literal_matrix
x
qs
)
lits
(
pats
,
indexs
)
=
unzip
pats_indexs
\end{code}
{-
@process_literals@ calls @process_explicit_literals@ to deal with the literals
that appears in the matrix and deal also with the rest of the cases. It
must be one Variable to be complete.
\begin{code}
-}
process_literals
::
[
HsLit
]
->
[(
EqnNo
,
EquationInfo
)]
->
([
ExhaustivePat
],
EqnSet
)
process_literals
used_lits
qs
...
...
@@ -285,12 +278,12 @@ process_literals used_lits qs
pats_default
=
[(
nlWildPatName
:
ps
,
constraints
)
|
(
ps
,
constraints
)
<-
(
pats'
)]
++
pats
indexs_default
=
unionUniqSets
indexs'
indexs
\end{code}
{-
Here we have selected the literal and we will select all the equations that
begins for that literal and create a new matrix.
-}
\begin{code}
construct_literal_matrix
::
HsLit
->
[(
EqnNo
,
EquationInfo
)]
->
([
ExhaustivePat
],
EqnSet
)
construct_literal_matrix
lit
qs
=
(
map
(
\
(
xs
,
ys
)
->
(
new_lit
:
xs
,
ys
))
pats
,
indexs
)
...
...
@@ -307,12 +300,12 @@ remove_first_column_lit lit qs
where
shift_pat
eqn
@
(
EqnInfo
{
eqn_pats
=
_
:
ps
})
=
eqn
{
eqn_pats
=
ps
}
shift_pat
_
=
panic
"Check.shift_var: no patterns"
\end{code}
{-
This function splits the equations @qs@ in groups that deal with the
same constructor.
-}
\begin{code}
split_by_constructor
::
[(
EqnNo
,
EquationInfo
)]
->
([
ExhaustivePat
],
EqnSet
)
split_by_constructor
qs
|
null
used_cons
=
(
[]
,
mkUniqSet
$
map
fst
qs
)
...
...
@@ -321,19 +314,19 @@ split_by_constructor qs
where
used_cons
=
get_used_cons
qs
unused_cons
=
get_unused_cons
used_cons
\end{code}
{-
The first column of the patterns matrix only have vars, then there is
nothing to do.
-}
\begin{code}
first_column_only_vars
::
[(
EqnNo
,
EquationInfo
)]
->
([
ExhaustivePat
],
EqnSet
)
first_column_only_vars
qs
=
(
map
(
\
(
xs
,
ys
)
->
(
nlWildPatName
:
xs
,
ys
))
pats
,
indexs
)
where
(
pats
,
indexs
)
=
check'
(
map
remove_var
qs
)
\end{code}
{-
This equation takes a matrix of patterns and split the equations by
constructor, using all the constructors that appears in the first column
of the pattern matching.
...
...
@@ -341,8 +334,8 @@ of the pattern matching.
We can need a default clause or not ...., it depends if we used all the
constructors or not explicitly. The reasoning is similar to @process_literals@,
the difference is that here the default case is not always needed.
-}
\begin{code}
no_need_default_case
::
[
Pat
Id
]
->
[(
EqnNo
,
EquationInfo
)]
->
([
ExhaustivePat
],
EqnSet
)
no_need_default_case
cons
qs
=
(
concat
pats
,
unionManyUniqSets
indexs
)
where
...
...
@@ -369,8 +362,8 @@ construct_matrix con qs =
(
map
(
make_con
con
)
pats
,
indexs
)
where
(
pats
,
indexs
)
=
(
check'
(
remove_first_column
con
qs
))
\end{code}
{-
Here remove first column is more difficult that with literals due to the fact
that constructors can have arguments.
...
...
@@ -384,8 +377,8 @@ is transformed in:
x xs y
_ _ y
\end{verbatim}
-}
\begin{code}
remove_first_column
::
Pat
Id
-- Constructor
->
[(
EqnNo
,
EquationInfo
)]
->
[(
EqnNo
,
EquationInfo
)]
...
...
@@ -536,8 +529,8 @@ is_var_lit _ (WildPat _) = True
is_var_lit
lit
pat
|
Just
lit'
<-
get_lit
pat
=
lit
==
lit'
|
otherwise
=
False
\end{code}
{-
The difference beteewn @make_con@ and @make_whole_con@ is that
@make_wole_con@ creates a new constructor with all their arguments, and
@make_con@ takes a list of argumntes, creates the contructor getting their
...
...
@@ -570,12 +563,12 @@ In particular:
\\ @((:) x xs)@ & returns to be & @(x:xs)@
\\ @(x:(...:[])@ & returns to be & @[x,...]@
\end{tabular}
%
The difficult case is the third one becouse we need to follow all the
contructors until the @[]@ to know that we need to use the second case,
not the second. \fbox{\ ???\ }
%
\begin{code}
-}
isInfixCon
::
DataCon
->
Bool
isInfixCon
con
=
isDataSymOcc
(
getOccName
con
)
...
...
@@ -629,8 +622,8 @@ make_whole_con con | isInfixCon con = nlInfixConPat name
where
name
=
getName
con
pats
=
[
nlWildPatName
|
_
<-
dataConOrigArgTys
con
]
\end{code}
{-
------------------------------------------------------------------------
Tidying equations
------------------------------------------------------------------------
...
...
@@ -640,8 +633,8 @@ that is, it removes syntactic sugar, reducing the number of cases that
must be handled by the main checking algorithm. One difference is
that here we can do *all* the tidying at once (recursively), rather
than doing it incrementally.
-}
\begin{code}
tidy_eqn
::
EquationInfo
->
EquationInfo
tidy_eqn
eqn
=
eqn
{
eqn_pats
=
map
tidy_pat
(
eqn_pats
eqn
),
eqn_rhs
=
tidy_rhs
(
eqn_rhs
eqn
)
}
...
...
@@ -778,4 +771,3 @@ tidy_con con (RecCon (HsRecFields fs _))
insertNm
nm
p
(
x
@
(
n
,
_
)
:
xs
)
|
nm
==
n
=
(
nm
,
p
)
:
xs
|
otherwise
=
x
:
insertNm
nm
p
xs
\end{code}
compiler/deSugar/Coverage.
l
hs
→
compiler/deSugar/Coverage.hs
View file @
4d5f83a8
%
%
(c) Galois, 2006
%
(c) University of Glasgow, 2007
%
\begin{code}
{-
(c) Galois, 2006
(c) University of Glasgow, 2007
-}
{-# LANGUAGE NondecreasingIndentation #-}
module
Coverage
(
addTicksToBinds
,
hpcInitCode
)
where
...
...
@@ -43,16 +43,15 @@ import Trace.Hpc.Util
import
BreakArray
import
Data.Map
(
Map
)
import
qualified
Data.Map
as
Map
\end{code}
{-
************************************************************************
* *
* The main function: addTicksToBinds
* *
************************************************************************
-}
%************************************************************************
%* *
%* The main function: addTicksToBinds
%* *
%************************************************************************
\begin{code}
addTicksToBinds
::
DynFlags
->
Module
...
...
@@ -526,7 +525,7 @@ addTickHsExpr (ExplicitList ty wit es) =
liftM3
ExplicitList
(
return
ty
)
(
addTickWit
wit
)
(mapM (addTickLHsExpr) es)
(
mapM
(
addTickLHsExpr
)
es
)
where
addTickWit
Nothing
=
return
Nothing
addTickWit
(
Just
fln
)
=
do
fln'
<-
addTickHsExpr
fln
return
(
Just
fln'
)
...
...
@@ -808,7 +807,7 @@ addTickHsCmd (HsCmdArrForm e fix cmdtop) =
(
return
fix
)
(
mapM
(
liftL
(
addTickHsCmdTop
))
cmdtop
)
addTickHsCmd (HsCmdCast co cmd)
addTickHsCmd
(
HsCmdCast
co
cmd
)
=
liftM2
HsCmdCast
(
return
co
)
(
addTickHsCmd
cmd
)
-- Others should never happen in a command context.
...
...
@@ -918,9 +917,7 @@ liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
liftL
f
(
L
loc
a
)
=
do
a'
<-
f
a
return
$
L
loc
a'
\end{code}
\begin{code}
data
TickTransState
=
TT
{
tickBoxCount
::
Int
,
mixEntries
::
[
MixEntry_
]
}
...
...
@@ -1164,18 +1161,12 @@ mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
hpcSrcSpan
::
SrcSpan
hpcSrcSpan
=
mkGeneralSrcSpan
(
fsLit
"Haskell Program Coverage internals"
)
\end{code}
\begin{code}
matchesOneOfMany
::
[
LMatch
Id
body
]
->
Bool
matchesOneOfMany
lmatches
=
sum
(
map
matchCount
lmatches
)
>
1
where
matchCount
(
L
_
(
Match
_pats
_ty
(
GRHSs
grhss
_binds
)))
=
length
grhss
\end{code}
\begin{code}
type
MixEntry_
=
(
SrcSpan
,
[
String
],
[
OccName
],
BoxLabel
)
-- For the hash value, we hash everything: the file name,
...
...
@@ -1187,13 +1178,13 @@ type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
mixHash
::
FilePath
->
UTCTime
->
Int
->
[
MixEntry
]
->
Int
mixHash
file
tm
tabstop
entries
=
fromIntegral
$
hashString
(
show
$
Mix
file
tm
0
tabstop
entries
)
\end{code}
%************************************************************************
%* *
%* initialisation
%* *
%************************************************************************
{-
************************************************************************
* *
* initialisation
* *
************************************************************************
Each module compiled with -fhpc declares an initialisation function of
the form `hpc_init_<module>()`, which is emitted into the _stub.c file
...
...
@@ -1207,8 +1198,8 @@ static void hpc_init_Main(void) __attribute__((constructor));
static void hpc_init_Main(void)
{extern StgWord64 _hpc_tickboxes_Main_hpc[];
hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
-}
\begin{code}
hpcInitCode
::
Module
->
HpcInfo
->
SDoc
hpcInitCode
_
(
NoHpcInfo
{})
=
Outputable
.
empty
hpcInitCode
this_mod
(
HpcInfo
tickCount
hashNo
)
...
...
@@ -1240,4 +1231,3 @@ hpcInitCode this_mod (HpcInfo tickCount hashNo)
=
module_name
|
otherwise
=
package_name
<>
char
'/'
<>
module_name
\end{code}
compiler/deSugar/Desugar.
l
hs
→
compiler/deSugar/Desugar.hs
View file @
4d5f83a8
%
%
(c) The University of Glasgow 2006
%
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
The Desugarer: turning HsSyn into Core.
-}
\begin{code}
{-# LANGUAGE CPP #-}
module
Desugar
(
deSugar
,
deSugarExpr
)
where
...
...
@@ -52,15 +52,15 @@ import OrdList
import
Data.List
import
Data.IORef
import
Control.Monad
(
when
)
\end{code}
%************************************************************************
%* *
%* The main function: deSugar
%* *
%************************************************************************
{-
************************************************************************
* *
* The main function: deSugar
* *
************************************************************************
-}
\begin{code}
-- | Main entry point to the desugarer.
deSugar
::
HscEnv
->
ModLocation
->
TcGblEnv
->
IO
(
Messages
,
Maybe
ModGuts
)
-- Can modify PCS by faulting in more declarations
...
...
@@ -212,8 +212,8 @@ combineEvBinds (NonRec b r : bs) val_prs
|
otherwise
=
NonRec
b
r
:
combineEvBinds
bs
val_prs
combineEvBinds
(
Rec
prs
:
bs
)
val_prs
=
combineEvBinds
bs
(
prs
++
val_prs
)
\end{code}
{-
Note [Top-level evidence]
~~~~~~~~~~~~~~~~~~~~~~~~~
Top-level evidence bindings may be mutually recursive with the top-level value
...
...
@@ -223,9 +223,8 @@ when computing dependencies.
So we pull out the type/coercion variables (which are in dependency order),
and Rec the rest.
-}
\begin{code}
deSugarExpr
::
HscEnv
->
LHsExpr
Id
->
IO
(
Messages
,
Maybe
CoreExpr
)
deSugarExpr
hsc_env
tc_expr
...
...
@@ -249,15 +248,15 @@ deSugarExpr hsc_env tc_expr
Just
expr
->
dumpIfSet_dyn
dflags
Opt_D_dump_ds
"Desugared"
(
pprCoreExpr
expr
)
;
return
(
msgs
,
mb_core_expr
)
}
\end{code}
%************************************************************************
%* *
%* Add rules and export flags to binders
%* *
%************************************************************************
{-
************************************************************************
* *
* Add rules and export flags to binders
* *
************************************************************************
-}
\begin{code}
addExportFlagsAndRules
::
HscTarget
->
NameSet
->
NameSet
->
[
CoreRule
]
->
[(
Id
,
t
)]
->
[(
Id
,
t
)]
...
...
@@ -299,9 +298,8 @@ addExportFlagsAndRules target exports keep_alive rules prs
is_exported
::
Name
->
Bool
is_exported
|
targetRetainsAllBindings
target
=
isExternalName
|
otherwise
=
(`
elemNameSet
`
exports
)
\end{code}
{-
Note [Adding export flags]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Set the no-discard flag if either
...
...
@@ -338,13 +336,12 @@ Reason
thereby get dropped
%************************************************************************
%* *
%* Desugaring transformation rules
%* *
%************************************************************************
\begin{code}
************************************************************************
* *
* Desugaring transformation rules
* *
************************************************************************
-}
dsRule
::
LRuleDecl
Id
->
DsM
(
Maybe
CoreRule
)
dsRule
(
L
loc
(
HsRule
name
act
vars
lhs
_tv_lhs
rhs
_fv_rhs
))
...
...
@@ -378,7 +375,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
inline_shadows_rule
-- Function can be inlined before rule fires
|
wopt
Opt_WarnInlineRuleShadowing
dflags
, isLocalId fn_id || hasSomeUnfolding (idUnfolding fn_id)
,
isLocalId
fn_id
||
hasSomeUnfolding
(
idUnfolding
fn_id
)
-- If imported with no unfolding, no worries
=
case
(
idInlineActivation
fn_id
,
act
)
of
(
NeverActive
,
_
)
->
False
...
...
@@ -422,8 +419,7 @@ unfold_coerce bndrs lhs rhs = do
(
bndrs
,
wrap
)
<-
go
vs
return
(
v
:
bndrs
,
wrap
)
\end{code}
{-
Note [Desugaring RULE left hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For the LHS of a RULE we do *not* want to desugar
...
...
@@ -455,13 +451,13 @@ corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
`let c = MkCoercible co in ...`. This is later simplified to the desired form
by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
%************************************************************************
%* *
%* Desugaring vectorisation declarations
%* *
%************************************************************************
************************************************************************
* *
* Desugaring vectorisation declarations
* *
************************************************************************
-}
\begin{code}
dsVect
::
LVectDecl
Id
->
DsM
CoreVect
dsVect
(
L
loc
(
HsVect
(
L
_
v
)
rhs
))
=
putSrcSpanDs
loc
$
...
...
@@ -486,4 +482,3 @@ dsVect (L _loc (HsVectInstOut inst))
=
return
$
VectInst
(
instanceDFunId
inst
)
dsVect
vi
@
(
L
_
(
HsVectInstIn
_
))
=
pprPanic
"Desugar.dsVect: unexpected 'HsVectInstIn'"
(
ppr
vi
)
\end{code}
compiler/deSugar/DsArrows.
l
hs
→
compiler/deSugar/DsArrows.hs
View file @
4d5f83a8
%
%
(c) The University of Glasgow 2006
%
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
Desugaring arrow commands
-}
\begin{code}
{-# LANGUAGE CPP #-}
module
DsArrows
(
dsProcExpr
)
where
...
...
@@ -48,9 +48,7 @@ import SrcLoc
import
ListSetOps
(
assocDefault
)
import
FastString
import
Data.List
\end{code}
\begin{code}
data
DsCmdEnv
=
DsCmdEnv
{
arr_id
,
compose_id
,
first_id
,
app_id
,
choice_id
,
loop_id
::
CoreExpr
}
...
...
@@ -137,12 +135,12 @@ mkSndExpr a_ty b_ty = do
pair_var
<-
newSysLocalDs
(
mkCorePairTy
a_ty
b_ty
)
return
(
Lam
pair_var
(
coreCasePair
pair_var
a_var
b_var
(
Var
b_var
)))
\end{code}
{-
Build case analysis of a tuple. This cannot be done in the DsM monad,
because the list of variables is typically not yet defined.
-}
\begin{code}
-- coreCaseTuple [u1..] v [x1..xn] body
-- = case v of v { (x1, .., xn) -> body }
-- But the matching may be nested if the tuple is very big
...
...
@@ -155,9 +153,7 @@ coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
coreCasePair
scrut_var
var1
var2
body
=
Case
(
Var
scrut_var
)
scrut_var
(
exprType
body
)
[(
DataAlt
(
tupleCon
BoxedTuple
2
),
[
var1
,
var2
],
body
)]
\end{code}
\begin{code}
mkCorePairTy
::
Type
->
Type
->
Type
mkCorePairTy
t1
t2
=
mkBoxedTupleTy
[
t1
,
t2
]
...
...
@@ -166,8 +162,8 @@ mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
mkCoreUnitExpr
::
CoreExpr
mkCoreUnitExpr
=
mkCoreTup
[]
\end{code}
{-
The input is divided into a local environment, which is a flat tuple
(unless it's too big), and a stack, which is a right-nested pair.
In general, the input has the form
...
...
@@ -176,8 +172,8 @@ In general, the input has the form
where xi are the environment values, and si the ones on the stack,
with s1 being the "top", the first one to be matched with a lambda.
-}
\begin{code}
envStackType
::
[
Id
]
->
Type
->
Type
envStackType
ids
stack_ty
=
mkCorePairTy
(
mkBigCoreVarTupTy
ids
)
stack_ty
...
...
@@ -250,17 +246,12 @@ matchVarStack (param_id:param_ids) stack_id body = do
(
tail_id
,
tail_code
)
<-
matchVarStack
param_ids
stack_id
body
pair_id
<-
newSysLocalDs
(
mkCorePairTy
(
idType
param_id
)
(
idType
tail_id
))
return
(
pair_id
,
coreCasePair
pair_id
param_id
tail_id
tail_code
)
\end{code}
\begin{code}
mkHsEnvStackExpr
::
[
Id
]
->
Id
->
LHsExpr
Id
mkHsEnvStackExpr
env_ids
stack_id
=
mkLHsTupleExpr
[
mkLHsVarTuple
env_ids
,
nlHsVar
stack_id
]
\end{code}
Translation of arrow abstraction
\begin{code}
-- Translation of arrow abstraction
-- D; xs |-a c : () --> t' ---> c'
-- --------------------------
...
...
@@ -287,8 +278,8 @@ dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
(
Lam
var
match_code
)
core_cmd
return
(
mkLets
meth_binds
proc_code
)
\end{code}
{-
Translation of a command judgement of the form
D; xs |-a c : stk --> t
...
...
@@ -296,8 +287,8 @@ Translation of a command judgement of the form
to an expression e such that
D |- e :: a (xs, stk) t
-}
\begin{code}
dsLCmd
::
DsCmdEnv
->
IdSet
->
Type
->
Type
->
LHsCmd
Id
->
[
Id
]
->
DsM
(
CoreExpr
,
IdSet
)
dsLCmd
ids
local_vars
stk_ty
res_ty
cmd
env_ids
...
...
@@ -483,8 +474,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
core_if
(
do_choice
ids
then_ty
else_ty
res_ty
core_then
core_else
),
fvs_cond
`
unionVarSet
`
fvs_then
`
unionVarSet
`
fvs_else
)
\end{code}
{-
Case commands are treated in much the same way as if commands
(see above) except that there are more alternatives. For example
...
...
@@ -509,8 +500,8 @@ case bodies, containing the following fields:
input type of the arrow
* a CoreExpr for an arrow built by combining the translated command
bodies with |||.
-}
\begin{code}
dsCmd
ids
local_vars
stack_ty
res_ty
(
HsCmdCase
exp
(
MG
{
mg_alts
=
matches
,
mg_arg_tys
=
arg_tys
,
mg_origin
=
origin
}))
env_ids
=
do
...
...
@@ -678,13 +669,11 @@ trimInput build_arrow
(
core_cmd
,
free_vars
)
<-
build_arrow
env_ids
return
(
core_cmd
,
free_vars
,
varSetElems
free_vars
))
\end{code}
{-
Translation of command judgements of the form