module Data.Tuple.Ops.Uncons (uncons, Uncons, Unconsable) where
import GHC.Generics (Generic(..), (:*:)(..), (:+:)(..), URec, Rec0, C1, D1, S1, M1(..), U1, K1(..), Meta(..), FixityI(..))
import GHC.TypeLits (Symbol)
import Data.Proxy
import Type.Family.Nat (N1)
import Data.Tuple.Ops.Internal
type RepOfPair t1 t2 = C1 ('MetaCons "(,)" 'PrefixI 'False) (S1 MetaS (Rec0 t1) :*: S1 MetaS (Rec0 t2))
type RepOfTuple c u = C1 ('MetaCons c 'PrefixI 'False) u
type family HeadR (f :: * -> *) :: * -> * where
HeadR (C1 mc (S1 ms (URec a))) = C1 mc (S1 ms (URec a))
HeadR (a :+: b) = a :+: b
HeadR (RepOfPair t1 t2) = UnD1 (Rep t1)
HeadR (RepOfTuple tcon (a :*: b :*: c)) = UnD1 (Rep (UnRec0 (UnS1 (N (T N1 (L (a :*: b :*: c)))))))
type family TailR (f :: * -> *) :: * -> * where
TailR (C1 mc (S1 ms (URec a))) = C1 ('MetaCons "()" 'PrefixI 'False) U1
TailR (a :+: b) = C1 ('MetaCons "()" 'PrefixI 'False) U1
TailR (RepOfPair t1 t2) = UnD1 (Rep t2)
TailR (RepOfTuple tcon (a :*: b :*: c)) = RepOfTuple (TupleConPred tcon) (N (D N1 (L (a :*: b :*: c))))
class UnconsR f where
unconsR :: f a -> (HeadR f a, TailR f a)
instance UnconsR (C1 mc (S1 ms (URec a))) where
unconsR a = (a, unM1 (from ()))
instance UnconsR (a :+: b) where
unconsR a = (a, unM1 (from ()))
instance (Generic t1, Rep t1 ~ D1 mt1 ct1,
Generic t2, Rep t2 ~ D1 mt2 ct2)
=> UnconsR (RepOfPair t1 t2) where
unconsR (M1 (a :*: b)) = (unM1 $ from $ unK1 $ unM1 a, unM1 $ from $ unK1 $ unM1 b)
instance (Linearize (a :*: b :*: c), L (a :*: b :*: c) ~ (S1 MetaS (Rec0 t) : w),
Generic t, Rep t ~ D1 hm hc, Normalize w)
=> UnconsR (RepOfTuple tcon (a :*: b :*: c)) where
unconsR a = let tup = linearize (unM1 a)
one = Proxy :: Proxy N1
h = unM1 $ from $ unK1 $ unM1 $ normalize $ take' one tup
t = M1 $ normalize $ drop' one tup
in (h, t)
type family TupleConPred (a :: Symbol) where
TupleConPred "(,,)" = "(,)"
TupleConPred "(,,,)" = "(,,)"
TupleConPred "(,,,,)" = "(,,,)"
TupleConPred "(,,,,,)" = "(,,,,)"
TupleConPred "(,,,,,,)" = "(,,,,,)"
TupleConPred "(,,,,,,,)" = "(,,,,,,)"
TupleConPred "(,,,,,,,,)" = "(,,,,,,,)"
TupleConPred "(,,,,,,,,,)" = "(,,,,,,,,)"
TupleConPred "(,,,,,,,,,,)" = "(,,,,,,,,,)"
TupleConPred "(,,,,,,,,,,,)" = "(,,,,,,,,,,)"
TupleConPred "(,,,,,,,,,,,,)" = "(,,,,,,,,,,,)"
TupleConPred "(,,,,,,,,,,,,,)" = "(,,,,,,,,,,,,)"
TupleConPred "(,,,,,,,,,,,,,,)" = "(,,,,,,,,,,,,,)"
TupleConPred "(,,,,,,,,,,,,,,,)" = "(,,,,,,,,,,,,,,)"
TupleConPred "(,,,,,,,,,,,,,,,,)" = "(,,,,,,,,,,,,,,,)"
type family Uncons a where
Uncons (a,b) = (a,b)
Uncons (a,b,c) = (a, (b,c))
Uncons (a,b,c,d) = (a, (b,c,d))
Uncons (a,b,c,d,e) = (a, (b,c,d,e))
Uncons (a,b,c,d,e,f) = (a, (b,c,d,e,f))
Uncons (a,b,c,d,e,f,g) = (a, (b,c,d,e,f,g))
Uncons (a,b,c,d,e,f,g,h) = (a, (b,c,d,e,f,g,h))
Uncons (a,b,c,d,e,f,g,h,i) = (a, (b,c,d,e,f,g,h,i))
Uncons (a,b,c,d,e,f,g,h,i,j) = (a, (b,c,d,e,f,g,h,i,j))
Uncons (a,b,c,d,e,f,g,h,i,j,k) = (a, (b,c,d,e,f,g,h,i,j,k))
Uncons (a,b,c,d,e,f,g,h,i,j,k,l) = (a, (b,c,d,e,f,g,h,i,j,k,l))
Uncons (a,b,c,d,e,f,g,h,i,j,k,l,m) = (a, (b,c,d,e,f,g,h,i,j,k,l,m))
Uncons (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = (a, (b,c,d,e,f,g,h,i,j,k,l,m,n))
Uncons (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = (a, (b,c,d,e,f,g,h,i,j,k,l,m,n,o))
Uncons (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) = (a, (b,c,d,e,f,g,h,i,j,k,l,m,n,o,p))
Uncons a = (a, ())
type Unconsable a b c = (Generic a, Generic b, Generic c, Uncons a ~ (b, c),
Rep a ~ D1 (MetaOfD1 (Rep a)) (UnD1 (Rep a)),
Rep b ~ D1 (MetaOfD1 (Rep b)) (UnD1 (Rep b)),
Rep c ~ D1 (MetaOfD1 (Rep c)) (UnD1 (Rep c)),
UnconsR (UnD1 (Rep a)),
HeadR (UnD1 (Rep a)) ~ (UnD1 (Rep b)),
TailR (UnD1 (Rep a)) ~ (UnD1 (Rep c)))
uncons :: Unconsable a b c => a -> (b, c)
uncons x = let (a, b) = unconsR $ unM1 $ from x in (to $ M1 a, to $ M1 b)