Improve External Core newtype syntax

[ghc-hetmet.git] / compiler / coreSyn / MkExternalCore.lhs

diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index 337b21a..34f39a5 100644 (file)
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -63,9 +63,18 @@ mkExternalCore :: CgGuts -> C.Module
 -- not been injected, so we have to add them manually here
 -- We don't include the strange data-con *workers* because they are
 -- implicit in the data type declaration itself
-mkExternalCore (CgGuts {cg_module=this_mod, cg_tycons = tycons, cg_binds = binds})
-  = (C.Module mname tdefs (runCoreM (mapM (make_vdef True) binds) 
-                            this_mod))
+mkExternalCore (CgGuts {cg_module=this_mod, cg_tycons = tycons, 
+                        cg_binds = binds})
+ -- Note that we flatten binds at the top level:
+ -- every module is just a single recursive bag of declarations.
+ -- Rationale: since modules can be mutually recursive, 
+ -- there's not much reason to preserve dependency info within a module.
+  = C.Module mname tdefs (case flattenBinds binds of
+                          -- check for empty list so we don't create an
+                          -- empty Rec group
+                            [] -> []
+                            bs  -> [(runCoreM (make_vdef True
+                                      (Rec bs)) this_mod)])
   where
     mname  = make_mid this_mod
     tdefs  = foldr collect_tdefs [] tycons
@@ -75,29 +84,17 @@ collect_tdefs tcon tdefs
   | isAlgTyCon tcon = tdef: tdefs
   where
     tdef | isNewTyCon tcon = 
-                C.Newtype (qtc tcon) (map make_tbind tyvars) 
+                C.Newtype (qtc tcon) 
                   (case newTyConCo_maybe tcon of
-                     Just co -> (qtc co, 
-                        map make_tbind vs, 
-                        make_kind (mkCoKind l r))
-                       where (vs,l,r) = coercionAxiom co
+                     Just co -> qtc co
                      Nothing       -> pprPanic ("MkExternalCore: newtype tcon\
                                        should have a coercion: ") (ppr tcon))
-                   repclause 
+                  (map make_tbind tyvars) 
+                  (make_ty (snd (newTyConRhs tcon)))
          | otherwise = 
                 C.Data (qtc tcon) (map make_tbind tyvars) 
                    (map make_cdef (tyConDataCons tcon)) 
-         where repclause | isRecursiveTyCon tcon || isOpenTyCon tcon= Nothing
-                        | otherwise = Just (make_ty (snd (newTyConRhs tcon)))
     tyvars = tyConTyVars tcon
-    coercionAxiom co = 
-      case isCoercionTyCon_maybe co of
-        -- See Note [Newtype coercions] in 
-        -- types/TyCon
-        Just (arity,coKindFun) | (l,r) <- (coKindFun $ map mkTyVarTy vs) -> 
-            (vs,l,r) where vs = take arity tyvars
-        Nothing -> pprPanic "MkExternalCore: coercion tcon lacks a kind fun"
-                     (ppr tcon)
 
 collect_tdefs _ tdefs = tdefs
 
@@ -226,8 +223,8 @@ make_ty' (TyVarTy tv)        = C.Tvar (make_var_id (tyVarName tv))
 make_ty' (AppTy t1 t2)                  = C.Tapp (make_ty t1) (make_ty t2)
 make_ty' (FunTy t1 t2)                  = make_ty (TyConApp funTyCon [t1,t2])
 make_ty' (ForAllTy tv t)        = C.Tforall (make_tbind tv) (make_ty t)
-make_ty' (TyConApp tc ts)       = foldl C.Tapp (C.Tcon (qtc tc)) 
-                                        (map make_ty ts)
+make_ty' (TyConApp tc ts)       = make_tyConApp tc ts
+
 -- Newtypes are treated just like any other type constructor; not expanded
 -- Reason: predTypeRep does substitution and, while substitution deals
 --        correctly with name capture, it's only correct if you see the uniques!
@@ -242,6 +239,25 @@ make_ty' (TyConApp tc ts)   = foldl C.Tapp (C.Tcon (qtc tc))
 
 make_ty' (PredTy p)    = make_ty (predTypeRep p)
 
+make_tyConApp :: TyCon -> [Type] -> C.Ty
+make_tyConApp tc [t1, t2] | tc == transCoercionTyCon =
+  C.TransCoercion (make_ty t1) (make_ty t2)
+make_tyConApp tc [t]      | tc == symCoercionTyCon =
+  C.SymCoercion (make_ty t)
+make_tyConApp tc [t1, t2] | tc == unsafeCoercionTyCon =
+  C.UnsafeCoercion (make_ty t1) (make_ty t2)
+make_tyConApp tc [t]      | tc == leftCoercionTyCon =
+  C.LeftCoercion (make_ty t)
+make_tyConApp tc [t]      | tc == rightCoercionTyCon =
+  C.RightCoercion (make_ty t)
+make_tyConApp tc [t1, t2] | tc == instCoercionTyCon =
+  C.InstCoercion (make_ty t1) (make_ty t2)
+-- this fails silently if we have an application
+-- of a wired-in coercion tycon to the wrong number of args.
+-- Not great...
+make_tyConApp tc ts =
+  foldl C.Tapp (C.Tcon (qtc tc)) 
+           (map make_ty ts)
 
 
 make_kind :: Kind -> C.Kind
@@ -257,7 +273,9 @@ make_kind _ = error "MkExternalCore died: make_kind"
 {- Id generation. -}
 
 make_id :: Bool -> Name -> C.Id
-make_id _is_var nm = (occNameString . nameOccName) nm
+-- include uniques for internal names in order to avoid name shadowing
+make_id _is_var nm = ((occNameString . nameOccName) nm)
+  ++ (if isInternalName nm then (show . nameUnique) nm else "")
 
 make_var_id :: Name -> C.Id
 make_var_id = make_id True