{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE DataKinds, TypeOperators #-}
{-# LANGUAGE GADTs, TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Data.OneOfThem (
	-- * OneOfThem
	-- ** Type
	OneOfThem,
	-- ** Single
	pattern Singleton, unSingleton,
	-- ** Multiple
	-- *** Project
	Projectable, project,
	-- *** Expand
	Expandable, (>-), expand,
	-- * OneOfThemFun
	-- ** Type and Apply
	OneOfThemFun, apply,
	-- ** Single
	pattern SingletonFun,
	-- ** Insert
	InsertableFun, (>--),
	-- ** Merge
	MergeableFun, mergeFun
	) where

import Data.Kind (Type)
import Data.Type.Set.Internal -- (Set(Nil, (:~)), Singleton)

data OneOfThem :: Set Type -> Type where
	JustIt :: a -> OneOfThem (a ':~ as)
	Wrap :: OneOfThem as -> OneOfThem (a ':~ as)

instance Show (OneOfThem 'Nil) where
	show :: OneOfThem 'Nil -> String
show OneOfThem 'Nil
_ = forall a. HasCallStack => String -> a
error String
"bad"

instance (Show a, Show (OneOfThem as)) => Show (OneOfThem (a :~ as)) where
	show :: OneOfThem (a ':~ as) -> String
show (JustIt a
x) = String
"(JustIt " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
x forall a. [a] -> [a] -> [a]
++ String
")"
	show (Wrap OneOfThem as
xs) = forall a. Show a => a -> String
show OneOfThem as
xs

{-# COMPLETE Singleton #-}

pattern Singleton :: a -> OneOfThem (Singleton a)
pattern $bSingleton :: forall a. a -> OneOfThem (Singleton a)
$mSingleton :: forall {r} {a}.
OneOfThem (Singleton a) -> (a -> r) -> ((# #) -> r) -> r
Singleton x = JustIt x

unSingleton :: OneOfThem (Singleton a) -> a
unSingleton :: forall a. OneOfThem (Singleton a) -> a
unSingleton (Singleton a
x) = a
x

class Expandable (as :: Set Type) (as' :: Set Type) where
	expand :: OneOfThem as -> OneOfThem as'

instance Expandable 'Nil as where expand :: OneOfThem 'Nil -> OneOfThem as
expand OneOfThem 'Nil
_ = forall a. HasCallStack => String -> a
error String
"never occur"

instance Expandable as as' => Expandable (a ':~ as) (a ':~ as') where
	expand :: OneOfThem (a ':~ as) -> OneOfThem (a ':~ as')
expand (JustIt a
x) = forall a (as :: Set (*)). a -> OneOfThem (a ':~ as)
JustIt a
x
	expand (Wrap OneOfThem as
oot) = forall (a :: Set (*)) as. OneOfThem a -> OneOfThem (as ':~ a)
Wrap forall a b. (a -> b) -> a -> b
$ forall (as :: Set (*)) (as' :: Set (*)).
Expandable as as' =>
OneOfThem as -> OneOfThem as'
expand OneOfThem as
oot

instance {-# OVERLAPPABLE #-} Expandable (a ':~ as) as' =>
	Expandable (a ':~ as) (a' ':~ as') where
	expand :: OneOfThem (a ':~ as) -> OneOfThem (a' ':~ as')
expand OneOfThem (a ':~ as)
x = forall (a :: Set (*)) as. OneOfThem a -> OneOfThem (as ':~ a)
Wrap forall a b. (a -> b) -> a -> b
$ forall (as :: Set (*)) (as' :: Set (*)).
Expandable as as' =>
OneOfThem as -> OneOfThem as'
expand OneOfThem (a ':~ as)
x

class Projectable (as :: Set Type) a where project :: OneOfThem as -> Maybe a

instance Projectable 'Nil a where project :: OneOfThem 'Nil -> Maybe a
project OneOfThem 'Nil
_ = forall a. Maybe a
Nothing
instance Projectable (a ':~ as) a where
	project :: OneOfThem (a ':~ as) -> Maybe a
project (JustIt a
x) = forall a. a -> Maybe a
Just a
x
	project (Wrap OneOfThem as
_) = forall a. Maybe a
Nothing
instance {-# OVERLAPPABLE #-} Projectable as a =>
	Projectable (a' ':~ as) a where
	project :: OneOfThem (a' ':~ as) -> Maybe a
project (JustIt a
_) = forall a. Maybe a
Nothing
	project (Wrap OneOfThem as
xs) = forall (as :: Set (*)) a.
Projectable as a =>
OneOfThem as -> Maybe a
project OneOfThem as
xs

class Collapsable (as :: Set Type) (as' :: Set Type) where
	collapse :: OneOfThem as -> Maybe (OneOfThem as')

instance Collapsable as 'Nil where collapse :: OneOfThem as -> Maybe (OneOfThem 'Nil)
collapse OneOfThem as
_ = forall a. Maybe a
Nothing

instance Collapsable as as' => Collapsable (a ':~ as) (a ':~ as') where
	collapse :: OneOfThem (a ':~ as) -> Maybe (OneOfThem (a ':~ as'))
collapse (JustIt a
x) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a (as :: Set (*)). a -> OneOfThem (a ':~ as)
JustIt a
x
	collapse (Wrap OneOfThem as
oot) = forall (a :: Set (*)) as. OneOfThem a -> OneOfThem (as ':~ a)
Wrap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (as :: Set (*)) (as' :: Set (*)).
Collapsable as as' =>
OneOfThem as -> Maybe (OneOfThem as')
collapse OneOfThem as
oot

instance {-# OVERLAPPABLE #-} Collapsable as (a' ':~ as') =>
	Collapsable (a ':~ as) (a' ':~ as') where
	collapse :: OneOfThem (a ':~ as) -> Maybe (OneOfThem (a' ':~ as'))
collapse (JustIt a
_) = forall a. Maybe a
Nothing
	collapse (Wrap OneOfThem as
oot) = forall (as :: Set (*)) (as' :: Set (*)).
Collapsable as as' =>
OneOfThem as -> Maybe (OneOfThem as')
collapse OneOfThem as
oot

data OneOfThemFun (as :: Set Type) b where
	EmptyFun :: OneOfThemFun 'Nil b
	(:..) :: (a -> b) -> OneOfThemFun as b -> OneOfThemFun (a ':~ as) b

class InsertableFun a (as :: Set Type) (as' :: Set Type) where
	(>--.) :: (a -> b) -> OneOfThemFun as b -> OneOfThemFun as' b

instance InsertableFun a as (a ':~ as) where a -> b
f >--. :: forall b.
(a -> b) -> OneOfThemFun as b -> OneOfThemFun (a ':~ as) b
>--. OneOfThemFun as b
fs = a -> b
f forall a b (as :: Set (*)).
(a -> b) -> OneOfThemFun as b -> OneOfThemFun (a ':~ as) b
:.. OneOfThemFun as b
fs

instance {-# OVERLAPPABLE #-} InsertableFun a as as' =>
	InsertableFun a (a' ':~ as) (a' ':~ as') where
	a -> b
f >--. :: forall b.
(a -> b)
-> OneOfThemFun (a' ':~ as) b -> OneOfThemFun (a' ':~ as') b
>--. (a -> b
g :.. OneOfThemFun as b
fs) = a -> b
g forall a b (as :: Set (*)).
(a -> b) -> OneOfThemFun as b -> OneOfThemFun (a ':~ as) b
:.. (a -> b
f forall a (as :: Set (*)) (as' :: Set (*)) b.
InsertableFun a as as' =>
(a -> b) -> OneOfThemFun as b -> OneOfThemFun as' b
>--. OneOfThemFun as b
fs)

infixr 5 >-, >--

(>--) :: InsertableFun a as (a :- as) => (a -> b) -> OneOfThemFun as b -> OneOfThemFun (a :- as) b
>-- :: forall a (as :: Set (*)) b.
InsertableFun a as (a :- as) =>
(a -> b) -> OneOfThemFun as b -> OneOfThemFun (a :- as) b
(>--) = forall a (as :: Set (*)) (as' :: Set (*)) b.
InsertableFun a as as' =>
(a -> b) -> OneOfThemFun as b -> OneOfThemFun as' b
(>--.)

{-# COMPLETE SingletonFun #-}

pattern SingletonFun :: (a -> b) -> OneOfThemFun (Singleton a) b
pattern $bSingletonFun :: forall a b. (a -> b) -> OneOfThemFun (Singleton a) b
$mSingletonFun :: forall {r} {a} {b}.
OneOfThemFun (Singleton a) b
-> ((a -> b) -> r) -> ((# #) -> r) -> r
SingletonFun f = f :.. EmptyFun

class Applyable as where
	apply :: OneOfThemFun as b -> OneOfThem as -> b

instance Applyable (Singleton a) where
	apply :: forall b.
OneOfThemFun (Singleton a) b -> OneOfThem (Singleton a) -> b
apply (SingletonFun a -> b
f) (Singleton a
x) = a -> b
f a
x

instance {-# OVERLAPPABLE #-} Applyable as => Applyable (a ':~ as) where
	apply :: forall b. OneOfThemFun (a ':~ as) b -> OneOfThem (a ':~ as) -> b
apply (a -> b
f :.. OneOfThemFun as b
_) (JustIt a
x) = a -> b
f a
x
	apply (a -> b
_ :.. OneOfThemFun as b
fs) (Wrap OneOfThem as
xs) = OneOfThemFun as b
fs forall (as :: Set (*)) b.
Applyable as =>
OneOfThemFun as b -> OneOfThem as -> b
`apply` OneOfThem as
xs

(>-) :: (Expandable (Singleton a) (a :- as), Expandable as (a :- as)) => a -> [OneOfThem as] -> [OneOfThem (a :- as)]
a
x >- :: forall a (as :: Set (*)).
(Expandable (Singleton a) (a :- as), Expandable as (a :- as)) =>
a -> [OneOfThem as] -> [OneOfThem (a :- as)]
>- [OneOfThem as]
xs = forall (as :: Set (*)) (as' :: Set (*)).
Expandable as as' =>
OneOfThem as -> OneOfThem as'
expand (forall a. a -> OneOfThem (Singleton a)
Singleton a
x) forall a. a -> [a] -> [a]
: (forall (as :: Set (*)) (as' :: Set (*)).
Expandable as as' =>
OneOfThem as -> OneOfThem as'
expand forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OneOfThem as]
xs)

class MergeableFun as as' mrg where
	mergeFun_ :: OneOfThemFun as b -> OneOfThemFun as' b -> OneOfThemFun mrg b

instance MergeableFun 'Nil 'Nil 'Nil where
	mergeFun_ :: forall b.
OneOfThemFun 'Nil b -> OneOfThemFun 'Nil b -> OneOfThemFun 'Nil b
mergeFun_ OneOfThemFun 'Nil b
EmptyFun OneOfThemFun 'Nil b
EmptyFun = forall b. OneOfThemFun 'Nil b
EmptyFun

instance MergeableFun as as' mrg => MergeableFun as (a' ':~ as') (a' ':~ mrg) where
	mergeFun_ :: forall b.
OneOfThemFun as b
-> OneOfThemFun (a' ':~ as') b -> OneOfThemFun (a' ':~ mrg) b
mergeFun_ OneOfThemFun as b
fs (a -> b
g :.. OneOfThemFun as b
gs) = a -> b
g forall a b (as :: Set (*)).
(a -> b) -> OneOfThemFun as b -> OneOfThemFun (a ':~ as) b
:.. forall (as :: Set (*)) (as' :: Set (*)) (mrg :: Set (*)) b.
MergeableFun as as' mrg =>
OneOfThemFun as b -> OneOfThemFun as' b -> OneOfThemFun mrg b
mergeFun_ OneOfThemFun as b
fs OneOfThemFun as b
gs

instance MergeableFun as as' mrg => MergeableFun (a ':~ as) as' (a ':~ mrg) where
	mergeFun_ :: forall b.
OneOfThemFun (a ':~ as) b
-> OneOfThemFun as' b -> OneOfThemFun (a ':~ mrg) b
mergeFun_ (a -> b
f :.. OneOfThemFun as b
fs) OneOfThemFun as' b
gs = a -> b
f forall a b (as :: Set (*)).
(a -> b) -> OneOfThemFun as b -> OneOfThemFun (a ':~ as) b
:.. forall (as :: Set (*)) (as' :: Set (*)) (mrg :: Set (*)) b.
MergeableFun as as' mrg =>
OneOfThemFun as b -> OneOfThemFun as' b -> OneOfThemFun mrg b
mergeFun_ OneOfThemFun as b
fs OneOfThemFun as' b
gs

mergeFun :: MergeableFun as as' (as :+: as') =>
	OneOfThemFun as b -> OneOfThemFun as' b -> OneOfThemFun (as :+: as') b
mergeFun :: forall (as :: Set (*)) (as' :: Set (*)) b.
MergeableFun as as' (as :+: as') =>
OneOfThemFun as b
-> OneOfThemFun as' b -> OneOfThemFun (as :+: as') b
mergeFun = forall (as :: Set (*)) (as' :: Set (*)) (mrg :: Set (*)) b.
MergeableFun as as' mrg =>
OneOfThemFun as b -> OneOfThemFun as' b -> OneOfThemFun mrg b
mergeFun_