X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fext-core%2FPrinter.hs;h=4e424452c3e099653617bf097f27434367342224;hp=0b6be42dc053386c0498096a27f280db71015b4e;hb=e4417dcd4679da9c6b18c02ff667199c572bed89;hpb=420a27dc9fb7de5fc6c96fe078ddd4dc87222d44

diff --git a/utils/ext-core/Printer.hs b/utils/ext-core/Printer.hs
index 0b6be42..4e42445 100644
--- a/utils/ext-core/Printer.hs
+++ b/utils/ext-core/Printer.hs
@@ -48,6 +48,9 @@ instance Show KindOrCoercion where
      shows (text "<C" <+> hsep (map ptbind tbs) <+>
               parens (pkind (Keq t1 t2)) <> text ">") 
 
+instance Show AnMname where
+  showsPrec _ mn = shows (panmname mn)
+
 indent = nest 2
 
 -- seems like this is asking for a type class...
@@ -63,14 +66,10 @@ ptdef (Data qtcon tbinds cdefs) =
   (text "%data" <+> pqname qtcon <+> (hsep (map ptbind tbinds)) <+> char '=')
   $$ indent (braces ((vcat (punctuate (char ';') (map pcdef cdefs)))))
 
-ptdef (Newtype qtcon tbinds (coercion,cTbs,k) tyopt) =
-  text "%newtype" <+> pqname qtcon <+> (hsep (map ptbind tbinds))
-    $$ indent (axiomclause $$ repclause)
-       where axiomclause = char '^' <+> parens (pqname coercion <+> 
-                                          (hsep (map ptbind cTbs)) <+>
-                                          text "::"
-                                      <+> peqkind k)
-	     repclause = case tyopt of
+ptdef (Newtype qtcon coercion tbinds tyopt) =
+  text "%newtype" <+> pqname qtcon <+> pqname coercion 
+    <+> (hsep (map ptbind tbinds)) $$ indent repclause
+       where repclause = case tyopt of
                            Just ty -> char '=' <+> pty ty 
                            Nothing -> empty
 
@@ -84,11 +83,9 @@ pqname (m,v) = pmname m <> pname v
 -- be sure to print the '.' here so we don't print out
 -- ".foo" for unqualified foo...
 pmname Nothing = empty
--- Notice that we print the "^" here; this is so that
--- "%module foo" doesn't get printed as "%module ^foo"
-pmname (Just m) = char '^' <> panmname m <> char '.'
+pmname (Just m) = panmname m <> char '.'
 
-panmname (pkgName, parents, name) =
+panmname (M (pkgName, parents, name)) =
   let parentStrs = map pname parents in
          pname pkgName <> char ':' <>
          -- This is to be sure to not print out:
@@ -124,16 +121,6 @@ peqkind (t1, t2) = parens (parens (pty t1) <+> text ":=:" <+> parens (pty t2))
 
 paty (Tvar n) = pname n
 paty (Tcon c) = pqname c
-paty (TransCoercion t1 t2) = 
-    parens (sep ([pqname transCoercion, pbty t1, pbty t2]))
-paty (SymCoercion t) = 
-    parens (sep [pqname symCoercion, paty t])
-paty (UnsafeCoercion t1 t2) = 
-    parens (sep [pqname unsafeCoercion, pbty t1, pbty t2])
-paty (LeftCoercion t) = 
-    parens (pqname leftCoercion <+> paty t)
-paty (RightCoercion t) = 
-    parens (pqname rightCoercion <+> paty t)
 paty t = parens (pty t)
 
 pbty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = parens(fsep [pbty t1, text "->",pty t2])
@@ -142,6 +129,18 @@ pbty t = paty t
 
 pty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = fsep [pbty t1, text "->",pty t2]
 pty (Tforall tb t) = text "%forall" <+> pforall [tb] t
+pty (TransCoercion t1 t2) = 
+    (sep ([pqname transCoercion, paty t1, paty t2]))
+pty (SymCoercion t) = 
+    (sep [pqname symCoercion, paty t])
+pty (UnsafeCoercion t1 t2) = 
+    (sep [pqname unsafeCoercion, paty t1, paty t2])
+pty (LeftCoercion t) = 
+    (pqname leftCoercion <+> paty t)
+pty (RightCoercion t) = 
+    (pqname rightCoercion <+> paty t)
+pty (InstCoercion t1 t2) = 
+    (sep [pqname instCoercion, paty t1, paty t2])
 pty t = pbty t
 
 pappty (Tapp t1 t2) ts = pappty t1 (t2:ts)