From 391a3e9c08c470bd1444cba2e5111e253c19ea84 Mon Sep 17 00:00:00 2001 From: Tim Chevalier Date: Sun, 4 May 2008 02:43:04 +0000 Subject: [PATCH] Improve syntax for primitive coercions in External Core Add new syntax in External Core for primitive coercions (trans, sym, etc.) rather than wiring their names into the ext-core parser. --- compiler/coreSyn/ExternalCore.lhs | 10 ++++++++++ compiler/coreSyn/MkExternalCore.lhs | 23 +++++++++++++++++++++-- compiler/coreSyn/PprExternalCore.lhs | 15 +++++++++++++-- utils/ext-core/ParsecParser.hs | 13 ++++++------- 4 files changed, 50 insertions(+), 11 deletions(-) diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs index a326a54..d8eaa3c 100644 --- a/compiler/coreSyn/ExternalCore.lhs +++ b/compiler/coreSyn/ExternalCore.lhs @@ -56,6 +56,16 @@ data Ty | Tcon (Qual Tcon) | Tapp Ty Ty | Tforall Tbind Ty +-- We distinguish primitive coercions +-- (represented in GHC by wired-in names), because +-- External Core treats them specially, so we have +-- to print them out with special syntax. + | TransCoercion Ty Ty + | SymCoercion Ty + | UnsafeCoercion Ty Ty + | InstCoercion Ty Ty + | LeftCoercion Ty + | RightCoercion Ty data Kind = Klifted diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index 99ea425..861f501 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -225,8 +225,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! @@ -241,6 +241,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 diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs index c34f7b8..25394e2 100644 --- a/compiler/coreSyn/PprExternalCore.lhs +++ b/compiler/coreSyn/PprExternalCore.lhs @@ -5,13 +5,12 @@ \begin{code} module PprExternalCore () where -import ExternalCore import Encoding +import ExternalCore import Pretty import Char - instance Show Module where showsPrec _ m = shows (pmodule m) @@ -103,6 +102,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 [text "%trans", paty t1, paty t2] +pty (SymCoercion t) = + sep [text "%sym", paty t] +pty (UnsafeCoercion t1 t2) = + sep [text "%unsafe", paty t1, paty t2] +pty (LeftCoercion t) = + sep [text "%left", paty t] +pty (RightCoercion t) = + sep [text "%right", paty t] +pty (InstCoercion t1 t2) = + sep [text "%inst", paty t1, paty t2] pty t = pbty t pappty :: Ty -> [Ty] -> Doc diff --git a/utils/ext-core/ParsecParser.hs b/utils/ext-core/ParsecParser.hs index 9acb138..ab0d284 100644 --- a/utils/ext-core/ParsecParser.hs +++ b/utils/ext-core/ParsecParser.hs @@ -222,13 +222,12 @@ coreTcon = data CoercionTy = TransC | InstC | SymC | UnsafeC | LeftC | RightC symCo, transCo, unsafeCo, instCo, leftCo, rightCo :: Parser CoercionTy --- Would be better not to wire these in quite this way. Sigh -symCo = string "ghczmprim:GHCziPrim.sym" >> return SymC -transCo = string "ghczmprim:GHCziPrim.trans" >> return TransC -unsafeCo = string "ghczmprim:GHCziPrim.CoUnsafe" >> return UnsafeC -leftCo = string "ghczmprim:GHCziPrim.left" >> return LeftC -rightCo = string "ghczmprim:GHCziPrim.right" >> return RightC -instCo = string "ghczmprim:GHCziPrim.inst" >> return InstC +symCo = string "%sym" >> return SymC +transCo = string "%trans" >> return TransC +unsafeCo = string "%unsafe" >> return UnsafeC +leftCo = string "%left" >> return LeftC +rightCo = string "%right" >> return RightC +instCo = string "%inst" >> return InstC coreForallTy :: Parser Ty coreForallTy = do -- 1.7.10.4