From: Adam Megacz Date: Tue, 10 May 2011 05:00:45 +0000 (-0700) Subject: update flattener to use type-family-based GArrow classes X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=549b6694dc6748e544eca9b8467aae75b737c9e7 update flattener to use type-family-based GArrow classes --- diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 476ab2f..10858f8 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -114,6 +114,9 @@ deSugar hsc_env , undefined , undefined , undefined + , undefined + , undefined + , undefined )) _ -> do (binds_cvr,ds_hpc_info, modBreaks) @@ -136,6 +139,9 @@ deSugar hsc_env ; hetmet_unflatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_unflatten_name else return undefined ; hetmet_flattened_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flattened_id_name else return undefined ; hetmet_PGArrow <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_name else return undefined + ; hetmet_PGArrow_unit <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_unit_name else return undefined + ; hetmet_PGArrow_tensor <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_tensor_name else return undefined + ; hetmet_PGArrow_exponent <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_exponent_name else return undefined ; hetmet_pga_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_id_name else return undefined ; hetmet_pga_comp <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_comp_name else return undefined ; hetmet_pga_first <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_first_name else return undefined @@ -165,6 +171,9 @@ deSugar hsc_env , hetmet_unflatten , hetmet_flattened_id , hetmet_PGArrow + , hetmet_PGArrow_unit + , hetmet_PGArrow_tensor + , hetmet_PGArrow_exponent , hetmet_pga_id , hetmet_pga_comp , hetmet_pga_first @@ -192,6 +201,9 @@ deSugar hsc_env , hetmet_unflatten , hetmet_flattened_id , hetmet_PGArrow + , hetmet_PGArrow_unit + , hetmet_PGArrow_tensor + , hetmet_PGArrow_exponent , hetmet_pga_id , hetmet_pga_comp , hetmet_pga_first @@ -244,6 +256,9 @@ deSugar hsc_env us ds_binds hetmet_PGArrow + hetmet_PGArrow_unit + hetmet_PGArrow_tensor + hetmet_PGArrow_exponent hetmet_pga_id hetmet_pga_comp hetmet_pga_first diff --git a/compiler/hetmet b/compiler/hetmet index 35d3a59..14afe39 160000 --- a/compiler/hetmet +++ b/compiler/hetmet @@ -1 +1 @@ -Subproject commit 35d3a59796735e5341389fa6a145f62dcea9c3fc +Subproject commit 14afe39e905be69eabd8944b97bb2b731bf44939 diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 3dccbfc..76ce5ce 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -217,6 +217,9 @@ basicKnownKeyNames hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name, hetmet_guest_char_literal_name, hetmet_PGArrow_name, + hetmet_PGArrow_unit_name, + hetmet_PGArrow_tensor_name, + hetmet_PGArrow_exponent_name, hetmet_pga_id_name, hetmet_pga_comp_name, hetmet_pga_first_name, @@ -283,6 +286,7 @@ gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS, gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST, gHC_HETMET_CODETYPES, gHC_HETMET_PRIVATE, + gHC_HETMET_GARROW, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception, gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL, @@ -307,6 +311,7 @@ gHC_INTEGER = mkIntegerModule (fsLit "GHC.Integer") gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type") gHC_HETMET_CODETYPES = mkBaseModule (fsLit "GHC.HetMet.CodeTypes") gHC_HETMET_PRIVATE = mkBaseModule (fsLit "GHC.HetMet.Private") +gHC_HETMET_GARROW = mkBaseModule (fsLit "GHC.HetMet.GArrow") gHC_LIST = mkBaseModule (fsLit "GHC.List") gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") @@ -817,6 +822,12 @@ hetmet_guest_char_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "guestCh hetmet_PGArrow_name :: Name hetmet_PGArrow_name = tcQual gHC_HETMET_PRIVATE (fsLit "PGArrow") hetmet_PGArrow_key +hetmet_PGArrow_unit_name :: Name +hetmet_PGArrow_unit_name = tcQual gHC_HETMET_GARROW (fsLit "GArrowUnit") hetmet_PGArrow_unit_key +hetmet_PGArrow_tensor_name :: Name +hetmet_PGArrow_tensor_name = tcQual gHC_HETMET_GARROW (fsLit "GArrowTensor") hetmet_PGArrow_tensor_key +hetmet_PGArrow_exponent_name :: Name +hetmet_PGArrow_exponent_name = tcQual gHC_HETMET_GARROW (fsLit "GArrowExponent") hetmet_PGArrow_exponent_key hetmet_pga_id_name :: Name hetmet_pga_id_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_id") hetmet_pga_id_key hetmet_pga_comp_name :: Name @@ -1458,6 +1469,12 @@ hetmet_pga_curryr_key = mkPreludeMiscIdUnique 154 hetmet_flatten_key = mkPreludeMiscIdUnique 155 hetmet_unflatten_key = mkPreludeMiscIdUnique 156 hetmet_flattened_id_key = mkPreludeMiscIdUnique 157 +hetmet_PGArrow_unit_key :: Unique +hetmet_PGArrow_unit_key = mkPreludeMiscIdUnique 158 +hetmet_PGArrow_tensor_key :: Unique +hetmet_PGArrow_tensor_key = mkPreludeMiscIdUnique 159 +hetmet_PGArrow_exponent_key :: Unique +hetmet_PGArrow_exponent_key = mkPreludeMiscIdUnique 160 diff --git a/libraries/base b/libraries/base index 9bcc30e..47c0024 160000 --- a/libraries/base +++ b/libraries/base @@ -1 +1 @@ -Subproject commit 9bcc30e533d29ee316a7ba572254765b97b4b0d0 +Subproject commit 47c002441ab30c48e93a0cd70a5f129f712329e0