Deal correctly with infix type constructors in GADT decls

[ghc-hetmet.git] / compiler / deSugar / DsForeign.lhs

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 725681e..46fc074 100644 (file)
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -28,12 +28,13 @@ import SMRep                ( argMachRep, typeCgRep )
 import CoreUtils       ( exprType, mkInlineMe )
 import Id              ( Id, idType, idName, mkSysLocal, setInlinePragma )
 import Literal         ( Literal(..), mkStringLit )
-import Module          ( moduleFS )
+import Module          ( moduleNameFS, moduleName )
 import Name            ( getOccString, NamedThing(..) )
 import Type            ( repType, coreEqType )
 import TcType          ( Type, mkFunTys, mkForAllTys, mkTyConApp,
                          mkFunTy, tcSplitTyConApp_maybe, tcSplitIOType_maybe,
                          tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
+                         isBoolTy
                        )
 
 import BasicTypes       ( Boxity(..) )
@@ -45,7 +46,7 @@ import ForeignCall    ( ForeignCall(..), CCallSpec(..),
                          ccallConvAttribute
                        )
 import TysWiredIn      ( unitTy, tupleTyCon )
-import TysPrim         ( addrPrimTy, mkStablePtrPrimTy, alphaTy )
+import TysPrim         ( addrPrimTy, mkStablePtrPrimTy, alphaTy, intPrimTy )
 import PrelNames       ( stablePtrTyConName, newStablePtrName, bindIOName,
                          checkDotnetResName )
 import BasicTypes      ( Activation( NeverActive ) )
@@ -350,10 +351,10 @@ dsFExportDynamic :: Id
                 -> DsM ([Binding], SDoc, SDoc)
 dsFExportDynamic id cconv
   =  newSysLocalDs ty                           `thenDs` \ fe_id ->
-     getModuleDs                               `thenDs` \ mod_name -> 
+     getModuleDs                               `thenDs` \ mod -> 
      let 
         -- hack: need to get at the name of the C stub we're about to generate.
-       fe_nm      = mkFastString (unpackFS (zEncodeFS (moduleFS mod_name)) ++ "_" ++ toCName fe_id)
+       fe_nm      = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName fe_id)
      in
      newSysLocalDs arg_ty                      `thenDs` \ cback ->
      dsLookupGlobalId newStablePtrName         `thenDs` \ newStablePtrId ->
@@ -629,16 +630,19 @@ ret_addr_arg = (text "original_return_addr", text "void*", undefined,
                typeMachRep addrPrimTy)
 
 -- This function returns the primitive type associated with the boxed
--- type argument to a foreign export (eg. Int ==> Int#).  It assumes
--- that all the types we are interested in have a single constructor
--- with a single primitive-typed argument, which is true for all of the legal
--- foreign export argument types (see TcType.legalFEArgTyCon).
+-- type argument to a foreign export (eg. Int ==> Int#).
 getPrimTyOf :: Type -> Type
-getPrimTyOf ty =
-  case splitProductType_maybe (repType ty) of
+getPrimTyOf ty
+  | isBoolTy rep_ty = intPrimTy
+  -- Except for Bool, the types we are interested in have a single constructor
+  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
+  | otherwise =
+  case splitProductType_maybe rep_ty of
      Just (_, _, data_con, [prim_ty]) ->
        ASSERT(dataConSourceArity data_con == 1)
        ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
        prim_ty
      _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
+  where
+       rep_ty = repType ty
 \end{code}