{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}
module Haskus.Utils.VariantF
( VariantF (..)
, ApplyAll
, pattern FV
, appendVariantF
, toVariantFHead
, toVariantFTail
, popVariantFHead
, variantFToValue
, MapVariantF
, mapVariantF
, PopVariantF
, popVariantF
, LiftVariantF
, liftVariantF
, AlterVariantF
, alterVariantF
, AlgVariantF
, algVariantF
, SplitVariantF
, splitVariantF
, variantFToCont
, variantFToContM
, contToVariantF
, contToVariantFM
, NoConstraint
, module Haskus.Utils.Functor
)
where
import Haskus.Utils.Variant
import Haskus.Utils.Functor
import Haskus.Utils.Types.List
import Haskus.Utils.Types.Constraint
import Haskus.Utils.ContFlow
import Unsafe.Coerce
import Data.Bifunctor
import GHC.Exts (Any)
import Control.DeepSeq
import Data.Functor.Classes
newtype VariantF (xs :: [* -> *]) e
= VariantF (V (ApplyAll e xs))
type family ApplyAll e (xs :: [* -> k]) :: [k] where
ApplyAll e '[] = '[]
ApplyAll e (f ': fs) = f e ': ApplyAll e fs
instance
( Eq1 (VariantF xs)
, ConstraintAll1 Eq1 xs
, Eq e
) => Eq (VariantF xs e)
where
(==) = eq1
instance
( Ord1 (VariantF xs)
, ConstraintAll1 Ord1 xs
, ConstraintAll1 Eq1 xs
, Ord e
) => Ord (VariantF xs e)
where
compare = compare1
instance Eq1 (VariantF '[]) where
liftEq = undefined
instance
( Eq1 f
, Eq1 (VariantF fs)
) => Eq1 (VariantF (f:fs)) where
liftEq cmp x y = case (popVariantFHead x, popVariantFHead y) of
(Right a, Right b) -> liftEq cmp a b
(Left a, Left b) -> liftEq cmp a b
_ -> False
instance Ord1 (VariantF '[]) where
liftCompare = undefined
instance
( Ord1 f
, Ord1 (VariantF fs)
) => Ord1 (VariantF (f:fs)) where
liftCompare cmp x@(VariantF v1) y@(VariantF v2) =
case (popVariantFHead x, popVariantFHead y) of
(Right a, Right b) -> liftCompare cmp a b
(Left a, Left b) -> liftCompare cmp a b
_ -> compare (variantIndex v1) (variantIndex v2)
instance Show1 (VariantF '[]) where
liftShowsPrec = undefined
instance
( Show1 f
, Show1 (VariantF fs)
) => Show1 (VariantF (f:fs)) where
liftShowsPrec shw shwl p x = case popVariantFHead x of
Right a -> liftShowsPrec shw shwl p a
Left a -> liftShowsPrec shw shwl p a
instance
( Show1 (VariantF xs)
, ConstraintAll1 Show1 xs
, Show e
) => Show (VariantF xs e)
where
showsPrec = showsPrec1
instance Functor (VariantF '[]) where
fmap _ = undefined
instance (Functor (VariantF fs), Functor f) => Functor (VariantF (f ': fs)) where
fmap f (VariantF v) = case popVariantHead v of
Right x -> toVariantFHead (fmap f x)
Left xs -> toVariantFTail (fmap f (VariantF xs))
pattern FV :: forall c cs e. c :< (ApplyAll e cs) => c -> VariantF cs e
pattern FV x = VariantF (V x)
variantFToValue :: VariantF '[f] e -> f e
variantFToValue (VariantF v) = variantToValue v
appendVariantF :: forall (ys :: [* -> *]) (xs :: [* -> *]) e.
( ApplyAll e (Concat xs ys) ~ Concat (ApplyAll e xs) (ApplyAll e ys)
) => VariantF xs e -> VariantF (Concat xs ys) e
appendVariantF (VariantF v) = VariantF (appendVariant @(ApplyAll e ys) v)
toVariantFHead :: forall x xs e. x e -> VariantF (x ': xs) e
{-# INLINE toVariantFHead #-}
toVariantFHead v = VariantF (toVariantHead @(x e) @(ApplyAll e xs) v)
toVariantFTail :: forall x xs e. VariantF xs e -> VariantF (x ': xs) e
{-# INLINE toVariantFTail #-}
toVariantFTail (VariantF v) = VariantF (toVariantTail @(x e) @(ApplyAll e xs) v)
popVariantFHead :: forall x xs e. VariantF (x ': xs) e -> Either (VariantF xs e) (x e)
{-# INLINE popVariantFHead #-}
popVariantFHead (VariantF v) = case popVariantHead v of
Right x -> Right x
Left xs -> Left (VariantF xs)
type PopVariantF x xs e =
( x e :< ApplyAll e xs
, Remove (x e) (ApplyAll e xs) ~ ApplyAll e (Remove x xs)
)
popVariantF :: forall x xs e.
( PopVariantF x xs e
) => VariantF xs e -> Either (VariantF (Remove x xs) e) (x e)
{-# INLINE popVariantF #-}
popVariantF (VariantF v) = case popVariant v of
Right x -> Right x
Left xs -> Left (VariantF xs)
type MapVariantF a b cs ds e =
( MapVariant (a e) (b e) (ApplyAll e cs)
, ds ~ ReplaceNS (IndexesOf a cs) b cs
, ApplyAll e ds ~ ReplaceNS (IndexesOf (a e) (ApplyAll e cs)) (b e) (ApplyAll e cs)
)
mapVariantF :: forall a b cs ds e.
( MapVariantF a b cs ds e
) => (a e -> b e) -> VariantF cs e -> VariantF ds e
mapVariantF f (VariantF v) = VariantF (mapVariant @(a e) @(b e) @(ApplyAll e cs) f v)
type LiftVariantF xs ys e =
( LiftVariant (ApplyAll e xs) (ApplyAll e ys)
)
liftVariantF :: forall as bs e.
( LiftVariantF as bs e
) => VariantF as e -> VariantF bs e
liftVariantF (VariantF v) = VariantF (liftVariant' v)
class AlterVariantF (c :: (* -> *) -> Constraint) e (xs :: [* -> *]) where
alterVariantF' :: (forall (f :: * -> *). c f => f e -> f e) -> Word -> Any -> Any
instance AlterVariantF c e '[] where
{-# INLINE alterVariantF' #-}
alterVariantF' _ = undefined
instance
( AlterVariantF c e xs
, c x
) => AlterVariantF c e (x ': xs)
where
{-# INLINE alterVariantF' #-}
alterVariantF' f t v =
case t of
0 -> unsafeCoerce (f (unsafeCoerce v :: x e))
n -> alterVariantF' @c @e @xs f (n-1) v
alterVariantF :: forall c e (xs :: [* -> *]).
( AlterVariantF c e xs
) => (forall (f :: * -> *). c f => f e -> f e) -> VariantF xs e -> VariantF xs e
{-# INLINABLE alterVariantF #-}
alterVariantF f (VariantF (Variant t a)) =
VariantF (Variant t (alterVariantF' @c @e @xs f t a))
class AlgVariantF (c :: (* -> *) -> Constraint) e r (xs :: [* -> *]) where
algVariantF' :: (forall (f :: * -> *). c f => f e -> r) -> Word -> Any -> r
instance AlgVariantF c e r '[] where
{-# INLINE algVariantF' #-}
algVariantF' _ = undefined
instance
( AlgVariantF c e r xs
, c x
) => AlgVariantF c e r (x ': xs)
where
{-# INLINE algVariantF' #-}
algVariantF' f t v =
case t of
0 -> f (unsafeCoerce v :: x e)
n -> algVariantF' @c @e @r @xs f (n-1) v
algVariantF :: forall c e r (xs :: [* -> *]).
( AlgVariantF c e r xs
) => (forall (f :: * -> *). c f => f e -> r) -> VariantF xs e -> r
{-# INLINABLE algVariantF #-}
algVariantF f (VariantF (Variant t a)) = algVariantF' @c @e @r @xs f t a
type SplitVariantF as xs e =
( Complement (ApplyAll e xs) (ApplyAll e as) ~ ApplyAll e (Complement xs as)
, SplitVariant (ApplyAll e as) (ApplyAll e (Complement xs as)) (ApplyAll e xs)
)
splitVariantF :: forall as xs e.
( SplitVariantF as xs e
) => VariantF xs e
-> Either (VariantF (Complement xs as) e) (VariantF as e)
splitVariantF (VariantF v) = bimap VariantF VariantF (splitVariant v)
variantFToCont :: ContVariant (ApplyAll e xs)
=> VariantF xs e -> ContFlow (ApplyAll e xs) r
variantFToCont (VariantF v) = variantToCont v
variantFToContM ::
( ContVariant (ApplyAll e xs)
, Monad m
) => m (VariantF xs e) -> ContFlow (ApplyAll e xs) (m r)
variantFToContM f = variantToContM (unvariantF <$> f)
where
unvariantF (VariantF v) = v
contToVariantF :: forall xs e.
( ContVariant (ApplyAll e xs)
) => ContFlow (ApplyAll e xs) (V (ApplyAll e xs)) -> VariantF xs e
contToVariantF c = VariantF (contToVariant c)
contToVariantFM :: forall xs e m.
( ContVariant (ApplyAll e xs)
, Monad m
) => ContFlow (ApplyAll e xs) (m (V (ApplyAll e xs))) -> m (VariantF xs e)
contToVariantFM f = VariantF <$> contToVariantM f
instance ContVariant (ApplyAll e xs) => MultiCont (VariantF xs e) where
type MultiContTypes (VariantF xs e) = ApplyAll e xs
toCont = variantFToCont
toContM = variantFToContM
deriving newtype instance (NFData (V (ApplyAll e xs))) => NFData (VariantF xs e)