X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=9826f2f88193363eb28392e333bd3d399dd03dc8;hb=6c2ae9c152d147623ac45a5fe52534c99d6ba835;hp=2def224906b2070b91c5962e606bb1a591f87335;hpb=ec29e12f0df59d01a7f82adee9f8cd2ab8c37b00;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 2def224..9826f2f 100644
--- 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"
-	  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
@@ -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
-       	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]
-   	    ++	(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 }
-       	  = [bindLex (ident_pat (wrapOpParens con_str)),
-       	     read_punc "{"]
+       	  = read_prefix_con 
+	    ++ [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)
-    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 "=",
@@ -1297,10 +1298,10 @@ genAuxBind loc (MkDataCon dc)	--  $cT1 etc
     fixity | is_infix  = infix_RDR
 	   | otherwise = prefix_RDR
 
-mk_data_type_name :: TyCon -> RdrName 	-- $tT
+mk_data_type_name :: TyCon -> RdrName 	-- "$tT"
 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
 
-mk_constr_name :: DataCon -> RdrName	-- $cC
+mk_constr_name :: DataCon -> RdrName	-- "$cC"
 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
 \end{code}