projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
one more missing patch from new codegen path
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcGenDeriv.lhs
diff --git
a/compiler/typecheck/TcGenDeriv.lhs
b/compiler/typecheck/TcGenDeriv.lhs
index
817e813
..
9826f2f
100644
(file)
--- a/
compiler/typecheck/TcGenDeriv.lhs
+++ b/
compiler/typecheck/TcGenDeriv.lhs
@@
-688,9
+688,7
@@
gen_Ix_binds loc tycon
data_con
= case tyConSingleDataCon_maybe tycon of -- just checking...
Nothing -> panic "get_Ix_binds"
data_con
= case tyConSingleDataCon_maybe tycon of -- just checking...
Nothing -> panic "get_Ix_binds"
- Just dc | any isUnLiftedType (dataConOrigArgTys dc)
- -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
- | otherwise -> dc
+ Just dc -> dc
con_arity = dataConSourceArity data_con
data_con_RDR = getRdrName data_con
con_arity = dataConSourceArity data_con
data_con_RDR = getRdrName data_con
@@
-843,22
+841,26
@@
gen_Read_binds get_fixity loc tycon
con_str = data_con_str data_con
prefix_parser = mk_parser prefix_prec prefix_stmts body
con_str = data_con_str data_con
prefix_parser = mk_parser prefix_prec prefix_stmts body
- prefix_stmts -- T a b c
- = (if not (isSym con_str) then
- [bindLex (ident_pat con_str)]
- else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"])
- ++ read_args
+
+ read_prefix_con
+ | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]
+ | otherwise = [bindLex (ident_pat con_str)]
+ read_infix_con
+ | isSym con_str = [bindLex (symbol_pat con_str)]
+ | otherwise = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]
+
+ prefix_stmts -- T a b c
+ = read_prefix_con ++ read_args
+
infix_stmts -- a %% b, or a `T` b
= [read_a1]
infix_stmts -- a %% b, or a `T` b
= [read_a1]
- ++ (if isSym con_str
- then [bindLex (symbol_pat con_str)]
- else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
+ ++ read_infix_con
++ [read_a2]
record_stmts -- T { f1 = a, f2 = b }
++ [read_a2]
record_stmts -- T { f1 = a, f2 = b }
- = [bindLex (ident_pat (wrapOpParens con_str)),
- read_punc "{"]
+ = read_prefix_con
+ ++ [read_punc "{"]
++ concat (intersperse [read_punc ","] field_stmts)
++ [read_punc "}"]
++ concat (intersperse [read_punc ","] field_stmts)
++ [read_punc "}"]
@@
-894,9
+896,8
@@
gen_Read_binds get_fixity loc tycon
data_con_str con = occNameString (getOccName con)
read_punc c = bindLex (punc_pat c)
data_con_str con = occNameString (getOccName con)
read_punc c = bindLex (punc_pat c)
- read_arg a ty
- | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
- | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
+ read_arg a ty = ASSERT( not (isUnLiftedType ty) )
+ noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
read_field lbl a = read_lbl lbl ++
[read_punc "=",
read_field lbl a = read_lbl lbl ++
[read_punc "=",