From 57e5bbbbab0d5315c6bba497447ff9bf2487e995 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Sat, 25 Sep 2021 21:45:43 +0200
Subject: Lots of stuff; can compile simple single-generate program

---
 SC/Defs.hs | 33 ++++++++++++++++++++-------------
 1 file changed, 20 insertions(+), 13 deletions(-)

(limited to 'SC/Defs.hs')

diff --git a/SC/Defs.hs b/SC/Defs.hs
index fac4e33..0ecf9cd 100644
--- a/SC/Defs.hs
+++ b/SC/Defs.hs
@@ -1,11 +1,13 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
 module SC.Defs where
 
 import Data.Array.Accelerate.AST.Idx
 import Data.Array.Accelerate.Representation.Array
 import Data.Array.Accelerate.Representation.Shape
 import Data.Array.Accelerate.Type
+import Data.Either (lefts, rights)
 
 import qualified Language.C as C
 import Language.C (Name(..))
@@ -68,39 +70,44 @@ data TypedAName = TypedAName C.Type Name
 
 data TupANames t where
     ANPair :: TupANames a -> TupANames b -> TupANames (a, b)
-    ANArray :: ShNames sh -> ITup TypedAName t -> TupANames (Array sh t)
+    ANArray :: ShNames sh -> ANames t -> TupANames (Array sh t)
     ANIgnore :: TupANames a
 
 -- Shape names and data array names
 tupanamesList :: TupANames t -> ([TypedName], [TypedAName])
-tupanamesList (ANPair a b) =
-    let (shn1, an1) = tupanamesList a
-        (shn2, an2) = tupanamesList b
-    in (shn1 ++ shn2, an1 ++ an2)
-tupanamesList (ANArray shn ns) = (shnamesList shn, itupList ns)
-tupanamesList ANIgnore = ([], [])
+tupanamesList an = let l = tupanamesList' an in (lefts l, rights l)
+
+tupanamesList' :: TupANames t -> [Either TypedName TypedAName]
+tupanamesList' (ANPair a b) = tupanamesList' a ++ tupanamesList' b
+tupanamesList' (ANArray shn ns) =
+    map Left (shnamesList shn) ++ map Right (itupList ns)
+tupanamesList' ANIgnore = []
 
 data ShNames sh where
     ShZ :: ShNames ()
-    ShS :: Name -> ShNames sh -> ShNames (sh, Int)
+    ShS :: ShNames sh -> Name -> ShNames (sh, Int)
+deriving instance Show (ShNames sh)
 
 shnamesList :: ShNames sh -> [TypedName]
-shnamesList ShZ = []
-shnamesList (ShS n shns) = TypedName (C.TInt C.B64) n : shnamesList shns
+shnamesList = reverse . go
+  where
+    go :: ShNames sh -> [TypedName]
+    go ShZ = []
+    go (ShS shns n) = TypedName (C.TInt C.B64) n : go shns
 
 makeShNames :: ShapeR sh -> ITup TypedName sh -> ShNames sh
 makeShNames ShapeRz ITupIgnore = ShZ
 makeShNames (ShapeRsnoc sht) (ITupPair ns (ITupSingle (TypedName _ n))) =
-    ShS n (makeShNames sht ns)
+    ShS (makeShNames sht ns) n
 makeShNames _ _ = error "wat"
 
 fromShNames :: ShNames sh -> ITup TypedName sh
 fromShNames ShZ = ITupIgnore
-fromShNames (ShS n ns) = ITupPair (fromShNames ns) (ITupSingle (TypedName (C.TInt C.B64) n))
+fromShNames (ShS ns n) = ITupPair (fromShNames ns) (ITupSingle (TypedName (C.TInt C.B64) n))
 
 shNamesShape :: ShNames sh -> ShapeR sh
 shNamesShape ShZ = ShapeRz
-shNamesShape (ShS _ ns) = ShapeRsnoc (shNamesShape ns)
+shNamesShape (ShS ns _) = ShapeRsnoc (shNamesShape ns)
 
 
 -- GENERATING VARIABLE NAMES
-- 
cgit v1.2.3-70-g09d2