Tweaks to XXX.THTuple

diff --git a/src/Dyna/XXX/THTuple.hs b/src/Dyna/XXX/THTuple.hs
index f86af45436b7d8ad5d32d657c05c235de69d5e9c..bbee260b8fca6958f4b82f0404568cc036f303d4 100644 (file)
--- a/src/Dyna/XXX/THTuple.hs
+++ b/src/Dyna/XXX/THTuple.hs
@@ -12,6 +12,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE Rank2Types #-}
@@ -67,11 +68,11 @@ $(mkMKRLTs ''MKRLT)
 --   e.g. RTER (a,b) r = (r a, r b)
 class (MKLT (TOL base) ~ base) => Tupled base where
   -- | Apply r to each element of the tuple
-  type RTER base (r :: * -> *) :: *
+  type RTER base (r :: k -> *) :: *
 
   -- | Go from the tuple representation to a promoted list;
   --   the inverse of MKLT (as asserted by class constraints).
-  type TOL base :: [*]
+  type TOL base :: [k]
 
   -- | Send a tuple to an HList
   tupleHL   :: base -> HList (TOL base)
@@ -99,8 +100,8 @@ class (Tupled (RTE arred),
        MKRLT (RTR arred) (TOL (RTE arred)) ~ arred
       )
       => RTupled arred where
-  type RTR arred :: (* -> *)
-  type RTE arred :: *
+  type RTR arred :: (k -> *)
+  type RTE arred :: k
 
   -- | Eliminate an rtuple out to a list.
   tupleopEL :: (RTR arred ~ r) => (forall x . r x -> a) -> arred -> [a]

diff --git a/src/Dyna/XXX/THTupleInternals.hs b/src/Dyna/XXX/THTupleInternals.hs
index 9cb46495ebee98d59b8008bd1651c52c8ba747c6..8b20c90401aa47280568d6fdb78418a282ed0747 100644 (file)
--- a/src/Dyna/XXX/THTupleInternals.hs
+++ b/src/Dyna/XXX/THTupleInternals.hs
@@ -22,7 +22,9 @@ import           Language.Haskell.TH
   -- XXX
 foreachTupleSize f = mapM f [2..10] -- maxTupleSize]
 
-mkNames n = mapM (newName . ("mti" ++) . show) [1..n]
+mkNames' pfx n = mapM (newName . (pfx ++) . show) [1..n]
+
+mkNames = mkNames' "mti"
 
 genMap app con var = foldl app con . map var
 
@@ -258,6 +260,52 @@ mkLRecInstances a b c = foreachTupleSize (mkLRecInstance a b c)
 ------------------------------------------------------------------------}}}
 -- Experimental detritus (XXX)                                          {{{
 
+-- Tuple-folding/mapping function generation                            
+
+{-
+-- | Monadic Tuple Fold and Map
+mkMTFoldMap :: Name               -- ^ Function name
+
+            -> Maybe Name         -- ^ Constructor, if any,
+                                  -- to be pattern matched away
+                                  
+            -> ExpQ               -- ^ Mapping applied at each element
+                                  --   Should be @a -> m b@
+
+            -> Maybe (ExpQ, ExpQ) -- ^ Common extractor and folder.
+                                  --   Should be @(b -> c, [c] -> m d)@
+                                  
+            -> Maybe ExpQ         -- ^ Map extractor.
+
+            -> Int                -- ^ Tuple size
+            -> Q Clause
+mkMTFoldMap fn mc m mcf mm n = do
+  tnames <- mkNames' "t" n
+  rnames <- mkNames' "r" n
+  mnames <- mkNames' "m" n
+
+  -- Build the pattern to extract arguments to tnames
+  let pat = maybe (id) (\na t -> conP na [t]) mc $
+            tupP $ map varP tnames
+
+  -- Apply m
+  rstmts <- mapM (\(te,re) -> bindS re $ appE m te) $ zip tnames rnames
+
+  -- Build folding result
+  let mfstmt = (\(e,f) -> appE f $ listE $ map (appE e . varE) rnames)
+               `fmap` mcf
+
+  -- Build mapping result
+  let mmstmt = (\m -> genMap appE (conE $ tupleDataName n)
+                      $ map (appE m . varE) rnames)
+               `fmap` mm
+
+  let pfx = rstmts
+  
+  clause pat (normalB $ doE pfx) []
+-}
+
+
 {-
 mkNpleFunction :: String -> TypeQ -> Int -> TypeQ
 mkNpleFunction _pfx rt n = do