From bddd67f4bfff1dcfac2cc0ad4d824788afed91e5 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Mon, 2 Sep 2024 22:14:47 +0200
Subject: accumPromote

---
 src/AST/Weaken/Auto.hs | 25 +++++++------------------
 1 file changed, 7 insertions(+), 18 deletions(-)

(limited to 'src/AST/Weaken')

diff --git a/src/AST/Weaken/Auto.hs b/src/AST/Weaken/Auto.hs
index 0deec71..eecb6f3 100644
--- a/src/AST/Weaken/Auto.hs
+++ b/src/AST/Weaken/Auto.hs
@@ -18,8 +18,7 @@
 {-# OPTIONS_GHC -Wno-partial-type-signatures #-}
 module AST.Weaken.Auto (
   autoWeak,
-  GivenSegment(..),
-  ($..),
+  ($..), auto,
   Layout(..),
 ) where
 
@@ -51,25 +50,15 @@ data SSegments (segments :: [(Symbol, [t])]) where
   SSegNil :: SSegments '[]
   SSegCons :: SSymbol name -> SList (Const ()) ts -> SSegments list -> SSegments ('(name, ts) : list)
 
-class ToSegments k a | a -> k where
-  type SegmentsOf k a :: [(Symbol, [k])]
-  toSegments :: a -> SSegments (SegmentsOf k a)
+instance (KnownSymbol name, name ~ name', segs ~ '[ '(name', ts)]) => IsLabel name (SList f ts -> SSegments segs) where
+  fromLabel = \spine -> SSegCons symbolSing (slistMap (\_ -> Const ()) spine) SSegNil
 
-instance ToSegments k (SSegments (segments :: [(Symbol, [k])])) where
-  type SegmentsOf k (SSegments segments) = segments
-  toSegments = id
-
-data GivenSegment name ts = forall f. KnownSymbol name => Seg (SList f ts)
-                          | (KnownSymbol name, KnownListSpine ts) => Seg'
-
-instance ToSegments k (GivenSegment name (ts :: [k])) where
-  type SegmentsOf k (GivenSegment name (ts :: [k])) = '[ '(name, ts)]
-  toSegments (Seg list) = SSegCons symbolSing (slistMap (\_ -> Const ()) list) SSegNil
-  toSegments Seg' = SSegCons symbolSing knownListSpine SSegNil
+auto :: KnownListSpine list => SList (Const ()) list
+auto = knownListSpine
 
 infixr $..
-($..) :: (ToSegments k a, ToSegments k b) => a -> b -> SSegments (Append (SegmentsOf k a) (SegmentsOf k b))
-x $.. y = ssegmentsAppend (toSegments x) (toSegments y)
+($..) :: SSegments segs1 -> SSegments segs2 -> SSegments (Append segs1 segs2)
+($..) = ssegmentsAppend
   where
     ssegmentsAppend :: SSegments a -> SSegments b -> SSegments (Append a b)
     ssegmentsAppend SSegNil l2 = l2
-- 
cgit v1.2.3-70-g09d2