module Data.RTuple where
import Prelude hiding (head, tail, map)
import Data.Typeable
import GHC.TypeLits
import Unsafe.Coerce (unsafeCoerce)
import Type.Bool
import Control.Lens
import Control.Lens.Wrapped
data RTuple a = RTuple { fromRTuple :: a } deriving (Eq, Ord)
data TList (t :: *) a = TList { fromTList :: a } deriving (Eq, Ord)
instance Wrapped (RTuple a) where
type Unwrapped (RTuple a) = a
_Wrapped' = iso fromRTuple RTuple
instance Wrapped (TList t a) where
type Unwrapped (TList t a) = a
_Wrapped' = iso fromTList TList
class ShowRtup r where
showRtup :: String -> r -> String
instance ShowRtup () where
showRtup _ _ = ""
instance Show a => ShowRtup (a,()) where
showRtup _ (a,()) = show a
instance (Show a, ShowRtup as) => ShowRtup (a,as) where
showRtup sep (a,as) = show a ++ sep ++ showRtup sep as
instance ShowRtup a => Show (RTuple a) where
show (RTuple a) = "RTuple (" ++ showRtup ", " a ++ ")"
type family HeadOf a
type instance HeadOf (RTuple (r,rs)) = r
type instance HeadOf (TList a l) = a
class Head a where
head :: Lens' a (HeadOf a)
instance Head (RTuple (r,rs)) where head = lens (fst . view _Wrapped') (\(RTuple (_,rs)) r -> RTuple (r,rs))
instance (a ~ r) => Head (TList a (r,rs)) where head = lens (fst . view _Wrapped') (\(TList (_,rs)) r -> TList (r,rs))
type family TailOf a
type instance TailOf (RTuple (r,rs)) = RTuple rs
type instance TailOf (TList a (r,rs)) = TList a rs
class Tail a where
tail :: Lens' a (TailOf a)
instance Tail (RTuple (r,rs)) where tail = lens (\(RTuple (r,rs)) -> RTuple rs) (\(RTuple (r,_)) (RTuple rs) -> RTuple (r,rs))
instance Tail (TList a (r,rs)) where tail = lens (\(TList (r,rs)) -> TList rs) (\(TList (r,_)) (TList rs) -> TList (r,rs))
class UncurryTuple f out | f -> out where
uncurryTuple :: f -> out
instance UncurryTuple (RTuple () -> a) a where
uncurryTuple f = f $ RTuple ()
instance UncurryTuple (RTuple xs -> f) fout => UncurryTuple (RTuple (x,xs) -> f) (x -> fout) where
uncurryTuple f = (\x -> uncurryTuple $ f . RTuple . (x,) . fromRTuple)
type family AsRTuple (a :: k)
type instance AsRTuple ('[] :: [*]) = RTuple ()
type instance AsRTuple ((l ': ls) :: [*]) = RTuple (l, Unwrapped (AsRTuple ls))
type family AsTListData t (a :: k)
type AsTList t lst = TList t (AsTListData t lst)
type instance AsTListData t ('[] :: [*]) = ()
type instance AsTListData t ((l ': ls) :: [*]) = (t, Unwrapped (AsTList t ls))
type family AsTuple a
type instance AsTuple (RTuple ()) = ()
type instance AsTuple (RTuple (t1,())) = t1
class ToTuple a lst | a -> lst where
toTuple :: a -> lst
instance ToTuple (RTuple ()) () where toTuple _ = ()
instance ToTuple (RTuple (t1,())) t1 where toTuple (RTuple (t1,())) = t1
instance ToTuple (RTuple (t1,(t2,()))) (t1,t2) where toTuple (RTuple (t1,(t2,()))) = (t1,t2)
instance ToTuple (RTuple (t1,(t2,(t3,())))) (t1,t2,t3) where toTuple (RTuple (t1,(t2,(t3,())))) = (t1,t2,t3)
instance ToTuple (RTuple (t1,(t2,(t3,(t4,()))))) (t1,t2,t3,t4) where toTuple (RTuple (t1,(t2,(t3,(t4,()))))) = (t1,t2,t3,t4)
instance ToTuple (RTuple (t1,(t2,(t3,(t4,(t5,())))))) (t1,t2,t3,t4,t5) where toTuple (RTuple (t1,(t2,(t3,(t4,(t5,())))))) = (t1,t2,t3,t4,t5)
instance ToTuple (RTuple (t1,(t2,(t3,(t4,(t5,(t6,()))))))) (t1,t2,t3,t4,t5,t6) where toTuple (RTuple (t1,(t2,(t3,(t4,(t5,(t6,()))))))) = (t1,t2,t3,t4,t5,t6)
instance ToTuple (RTuple (t1,(t2,(t3,(t4,(t5,(t6,(t7,())))))))) (t1,t2,t3,t4,t5,t6,t7) where toTuple (RTuple (t1,(t2,(t3,(t4,(t5,(t6,(t7,())))))))) = (t1,t2,t3,t4,t5,t6,t7)
instance ToTuple (RTuple (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,()))))))))) (t1,t2,t3,t4,t5,t6,t7,t8) where toTuple (RTuple (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,()))))))))) = (t1,t2,t3,t4,t5,t6,t7,t8)
instance ToTuple (RTuple (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,(t9,())))))))))) (t1,t2,t3,t4,t5,t6,t7,t8,t9) where toTuple (RTuple (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,(t9,())))))))))) = (t1,t2,t3,t4,t5,t6,t7,t8,t9)
instance ToTuple (RTuple (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,(t9,(t10,()))))))))))) (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10) where toTuple (RTuple (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,(t9,(t10,()))))))))))) = (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10)
instance ToTuple (RTuple (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,(t9,(t10,(t11,())))))))))))) (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11) where toTuple (RTuple (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,(t9,(t10,(t11,())))))))))))) = (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11)
instance ToTuple (RTuple (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,(t9,(t10,(t11,(t12,()))))))))))))) (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12) where toTuple (RTuple (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,(t9,(t10,(t11,(t12,()))))))))))))) = (t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12)
type family ElTypeAt (idx :: Nat) a
class ElAt idx a where
elAt :: Proxy idx -> Lens' a (ElTypeAt idx a)
class ElAt' idx t where
elAt' :: Proxy idx -> Lens' (TList t lst) t
type instance ElTypeAt n (RTuple (r,rs)) = If (n :== 0) r (ElTypeAt (n 1) (RTuple rs))
type instance ElTypeAt n (TList t lst) = t
instance ( ElAt (n 1) (RTuple rs)
, ElTypeAt n (RTuple (r,rs)) ~ ElTypeAt (n1) (RTuple rs)
) => ElAt n (RTuple (r,rs)) where elAt _ = tail . elAt (Proxy :: Proxy (n1))
instance ElAt 0 (RTuple (r,rs)) where elAt _ = head
instance ( ElAt (n 1) (TList t rs)
, ElTypeAt n (TList t (r,rs)) ~ ElTypeAt (n1) (TList t rs)
) => ElAt n (TList t (r,rs)) where elAt _ = tail . elAt (Proxy :: Proxy (n1))
instance (t ~ r) => ElAt 0 (TList t (r,rs)) where elAt _ = head