module Data.Flex.Wrap where
import Control.Applicative (Applicative(..))
import Data.Foldable as F (Foldable(..))
import qualified Data.Traversable as T (Traversable(..))
import Data.Type.Apply (Apply(..))
import Data.Type.Eq (TypeCast)
import Data.Type.TList ((:*:), TNil)
import Data.Flex.Utils (inCompose, inCompose2)
newtype FlexiWrap s a = FlexiWrap {unFlexiWrap :: a}
type FW = FlexiWrap
flexiWrap :: s -> a -> FW s a
flexiWrap _ = FlexiWrap
inFlexiWrap :: (a -> b) -> (FW s a -> FW s b)
inFlexiWrap = inCompose unFlexiWrap FlexiWrap
inFlexiWrap2 :: (a -> b -> c) -> (FW s a -> FW s b -> FW s c)
inFlexiWrap2 = inCompose2 unFlexiWrap FlexiWrap
instance Functor (FW t) where
fmap = inFlexiWrap
instance Applicative (FW t) where
pure = FlexiWrap
(<*>) = inFlexiWrap . unFlexiWrap
instance F.Foldable (FW t) where
foldr f z (FlexiWrap a) = f a z
instance T.Traversable (FW t) where
traverse = (fmap FlexiWrap .) . (. unFlexiWrap)
sequenceA = fmap FlexiWrap . unFlexiWrap
instance Monad (FW t) where
return = FlexiWrap
(>>=) = flip (. unFlexiWrap)
class FWNormAppend s t u | s t -> u
instance FWNormAppend TNil t t
instance FWNormAppend s t u => FWNormAppend (x :*: s) t (x :*: u)
instance TypeCast u (x :*: t) => FWNormAppend x t u
class FWrap w a b | w a -> b where
fWrap :: w -> a -> b
class FWIsWrapped a r | a -> r
data FWAlreadyWrapped = FWAlreadyWrapped
data FWNewWrapper = FWNewWrapper
data FWFWrap s a = FWFWrap
instance FWIsWrapped (FW s a) FWAlreadyWrapped
instance TypeCast r FWNewWrapper => FWIsWrapped a r
instance Apply (FWFWrap u a) FWNewWrapper (a -> FW u a) where
apply _ _ = FlexiWrap
instance Apply (FWFWrap u (FW s a)) FWAlreadyWrapped (FW s a -> FW u a) where
apply _ _ = FlexiWrap . unFlexiWrap
data FWTag
instance Apply FWTag (FW t a) t
instance TypeCast r TNil => Apply FWTag a r
instance forall a b s t u w. (
Apply FWTag a t,
FWNormAppend s t u,
FWIsWrapped a w,
Apply (FWFWrap u a) w (a -> FW u b)
) =>
FWrap s a (FW u b)
where
fWrap _ = apply (undefined :: FWFWrap u a) (undefined :: w)
infixl 8 `on`
on :: (b -> b -> c) -> (a -> b) -> (a -> a -> c)
(op `on` f) x y = f x `op` f y
class FWEq a r | a -> r
data FWDefaultEq = FWDefaultEq
data FWEquals t a = FWEquals
data FWNotEquals t a = FWNotEquals
instance TypeCast r FWDefaultEq => FWEq (FW t a) r
instance FWEq (FW s a) r => FWEq (FW (x :*: s) a) r
instance Eq a => Apply (FWEquals t a) FWDefaultEq (FW t a -> FW t a -> Bool)
where
apply _ _ = (==) `on` unFlexiWrap
instance Eq a => Apply (FWNotEquals t a) FWDefaultEq (FW t a -> FW t a -> Bool)
where
apply _ _ = (/=) `on` unFlexiWrap
instance forall t a r. (Apply (FWEquals t a) r (FW t a -> FW t a -> Bool),
Apply (FWNotEquals t a) r (FW t a -> FW t a -> Bool),
FWEq (FW t a) r
) =>
Eq (FW t a) where
(==) = apply (undefined :: FWEquals t a) (undefined :: r)
(/=) = apply (undefined :: FWNotEquals t a) (undefined :: r)