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 (file)
--- 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 (submodule)
--- 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 (file)
--- 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 (submodule)
--- a/libraries/base
+++ b/libraries/base
@@ -1 +1 @@
-Subproject commit 9bcc30e533d29ee316a7ba572254765b97b4b0d0
+Subproject commit 47c002441ab30c48e93a0cd70a5f129f712329e0