git.iko.soy/reflex
on 7bb5ff4 help sign in
reflex/src/Data/Functor/Misc.hs
76 lines 3.2 kB history raw
1{-# LANGUAGE KindSignatures, GADTs, DeriveDataTypeable, RankNTypes, ScopedTypeVariables, PolyKinds #-}
2module Data.Functor.Misc where
4import Data.GADT.Compare
5import Data.Map (Map)
6import qualified Data.Map as Map
7import Data.Dependent.Map (DMap, DSum (..))
8import qualified Data.Dependent.Map as DMap
9import Data.Typeable hiding (Refl)
10import Data.These
11import Control.Monad.Identity
13data WrapArg :: (k -> *) -> (k -> *) -> * -> * where
14 WrapArg :: f a -> WrapArg g f (g a)
16instance GEq f => GEq (WrapArg g f) where
17 geq (WrapArg a) (WrapArg b) = fmap (\Refl -> Refl) $ geq a b
19instance GCompare f => GCompare (WrapArg g f) where
20 gcompare (WrapArg a) (WrapArg b) = case gcompare a b of
21 GLT -> GLT
22 GEQ -> GEQ
23 GGT -> GGT
25data Const2 :: * -> * -> * -> * where
26 Const2 :: k -> Const2 k v v
27 deriving (Typeable)
29instance Eq k => GEq (Const2 k v) where
30 geq (Const2 a) (Const2 b) =
31 if a == b
32 then Just Refl
33 else Nothing
35instance Ord k => GCompare (Const2 k v) where
36 gcompare (Const2 a) (Const2 b) = case compare a b of
37 LT -> GLT
38 EQ -> GEQ
39 GT -> GGT
41{-# INLINE sequenceDmap #-}
42sequenceDmap :: (Monad m, GCompare f) => DMap f m -> m (DMap f Identity)
43sequenceDmap = DMap.foldrWithKey (\k mv mx -> mx >>= \x -> mv >>= \v -> return $ DMap.insert k (Identity v) x)
44 (return DMap.empty)
46{-# INLINE combineDMapsWithKey #-}
47combineDMapsWithKey :: forall f g h i. GCompare f => (forall (a :: *). f a -> These (g a) (h a) -> i a) -> DMap f g -> DMap f h -> DMap f i
48combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)
49 where go :: [DSum f g] -> [DSum f h] -> [DSum f i]
50 go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs
51 go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs
52 go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of
53 GLT -> (gk :=> f gk (This gv)) : go gs' hs
54 GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'
55 GGT -> (hk :=> f hk (That hv)) : go gs hs'
57wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f
58wrapDMap f = DMap.fromDistinctAscList . map (\(k :=> Identity v) -> k :=> f v) . DMap.toAscList
60rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g
61rewrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> k :=> f v) . DMap.toAscList
63unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity
64unwrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> k :=> Identity (f v)) . DMap.toAscList
66unwrapDMapMaybe :: (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity
67unwrapDMapMaybe f m = DMap.fromDistinctAscList [k :=> Identity w | (k :=> v) <- DMap.toAscList m, Just w <- [f v]]
69mapToDMap :: Map k v -> DMap (Const2 k v) Identity
70mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList
72mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f
73mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> (Const2 k) :=> v) . Map.toAscList
75dmapToMap :: DMap (Const2 k v) Identity -> Map k v
76dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList