{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE DataKinds, TypeOperators #-}
{-# LANGUAGE GADTs, TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}
module Data.OneOfThem (
OneOfThem,
pattern Singleton, unSingleton,
Projectable, project,
Expandable, (>-), expand,
OneOfThemFun, apply,
pattern SingletonFun,
InsertableFun, (>--),
MergeableFun, mergeFun
) where
import Data.Kind (Type)
import Data.Type.Set.Internal
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_