git.iko.soy/reflex
on fast-weak-partial-requester help sign in
reflex/src/Data/Functor/Misc.hs
345 lines 13 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE KindSignatures #-}
8{-# LANGUAGE LambdaCase #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE PatternSynonyms #-}
11{-# LANGUAGE PolyKinds #-}
12{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE StandaloneDeriving #-}
15#ifdef USE_REFLEX_OPTIMIZER
16{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
17#endif
18-- | This module provides types and functions with no particular theme, but
19-- which are relevant to the use of 'Functor'-based datastructures like
20-- 'Data.Dependent.Map.DMap'.
21module Data.Functor.Misc
22 ( -- * Const2
23 Const2 (..)
24 , unConst2
25 , dmapToMap
26 , dmapToMapWith
27 , mapToDMap
28 , weakenDMapWith
29 -- * WrapArg
30 , WrapArg (..)
31 -- * Convenience functions for DMap
32 , mapWithFunctorToDMap
33 , mapKeyValuePairsMonotonic
34 , combineDMapsWithKey
35 , EitherTag (..)
36 , dmapToThese
37 , eitherToDSum
38 , dsumToEither
39 -- * Deprecated functions
40 , sequenceDmap
41 , wrapDMap
42 , rewrapDMap
43 , unwrapDMap
44 , unwrapDMapMaybe
45 , extractFunctorDMap
46 , ComposeMaybe (..)
47 ) where
49import Control.Applicative (Applicative, (<$>))
50import Control.Monad.Identity
51import Data.Dependent.Map (DMap)
52import qualified Data.Dependent.Map as DMap
53import Data.Dependent.Sum
54import Data.GADT.Compare
55import Data.GADT.Show
56import Data.Map (Map)
57import qualified Data.Map as Map
58import Data.Some (Some)
59import qualified Data.Some as Some
60import Data.These
61import Data.Typeable hiding (Refl)
63--------------------------------------------------------------------------------
64-- Const2
65--------------------------------------------------------------------------------
67-- | 'Const2' stores a value of a given type 'k' and ensures that a particular
68-- type 'v' is always given for the last type parameter
69data Const2 :: * -> x -> x -> * where
70 Const2 :: k -> Const2 k v v
71 deriving (Typeable)
73unConst2 :: Const2 k v v' -> k
74unConst2 (Const2 k) = k
76deriving instance Eq k => Eq (Const2 k v v')
77deriving instance Ord k => Ord (Const2 k v v')
78deriving instance Show k => Show (Const2 k v v')
79deriving instance Read k => Read (Const2 k v v)
81instance Show k => GShow (Const2 k v) where
82#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
83 gshowToShow (Const2 _) = id
84#else
85 gshowsPrec n x@(Const2 _) = showsPrec n x
86#endif
88instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where
89#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
90 showTagToShow (Const2 _) _ = id
91#else
92 showTaggedPrec (Const2 _) = showsPrec
93#endif
95instance Eq k => GEq (Const2 k v) where
96#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
97 geqToEq _ = id
98 geqUnify (Const2 _) (Const2 _) _ = id
99#else
100 geq (Const2 a) (Const2 b) =
101 if a == b
102 then Just Refl
103 else Nothing
104#endif
106instance Ord k => GCompare (Const2 k v) where
107#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
108 gcompareToOrd (Const2 _) = id
109 gcompare (Const2 a) (Const2 b) = strengthenOrdering $ compare a b
110#else
111 gcompare (Const2 a) (Const2 b) = case compare a b of
112 LT -> GLT
113 EQ -> GEQ
114 GT -> GGT
115#endif
117#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
118instance {-# INCOHERENT #-} (Eq k, Eq v) => EqTag (Const2 k v) Identity where
119 eqTagToEq (Const2 _) _ = id
121instance {-# INCOHERENT #-} Eq k => EqTag (Const2 k v) (Const2 k v) where
122 eqTagToEq (Const2 _) _ = id
123#endif
125-- | Convert a 'DMap' to a regular 'Map'
126dmapToMap :: DMap (Const2 k v) Identity -> Map k v
127dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
129dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v'
130dmapToMapWith f = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, f v)) . DMap.toAscList
132-- | Convert a regular 'Map' to a 'DMap'
133mapToDMap :: Map k v -> DMap (Const2 k v) Identity
134mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList
136-- | Convert a regular 'Map', where the values are already wrapped in a functor,
137-- to a 'DMap'
138mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f
139mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList
141weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'
142weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some.This k, f v)) . DMap.toAscList
144--------------------------------------------------------------------------------
145-- WrapArg
146--------------------------------------------------------------------------------
148-- | 'WrapArg' can be used to tag a value in one functor with a type
149-- representing another functor. This was primarily used with dependent-map <
150-- 0.2, in which the value type was not wrapped in a separate functor.
151data WrapArg :: (k -> *) -> (k -> *) -> * -> * where
152 WrapArg :: f a -> WrapArg g f (g a)
154deriving instance Eq (f a) => Eq (WrapArg g f (g' a))
155deriving instance Ord (f a) => Ord (WrapArg g f (g' a))
156deriving instance Show (f a) => Show (WrapArg g f (g' a))
157deriving instance Read (f a) => Read (WrapArg g f (g a))
159instance GEq f => GEq (WrapArg g f) where
160#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
161 geqToEq (WrapArg f) = geqToEq f
162 geqUnify (WrapArg a) (WrapArg b) = geqUnify a b
163#else
164 geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b
165#endif
167instance GCompare f => GCompare (WrapArg g f) where
168#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
169 gcompareToOrd (WrapArg f) = gcompareToOrd f
170#endif
171 gcompare (WrapArg a) (WrapArg b) = case gcompare a b of
172 GLT -> GLT
173 GEQ -> GEQ
174 GGT -> GGT
176--------------------------------------------------------------------------------
177-- Convenience functions for DMap
178--------------------------------------------------------------------------------
180-- | Map over all key/value pairs in a 'DMap', potentially altering the key as
181-- well as the value. The provided function MUST preserve the ordering of the
182-- keys, or the resulting 'DMap' will be malformed.
183mapKeyValuePairsMonotonic :: (DSum k v -> DSum k' v') -> DMap k v -> DMap k' v'
184mapKeyValuePairsMonotonic f = DMap.fromDistinctAscList . map f . DMap.toAscList
186{-# INLINE combineDMapsWithKey #-}
187-- | Union two 'DMap's of different types, yielding another type. Each key that
188-- is present in either input map will be present in the output.
189combineDMapsWithKey :: forall f g h i.
190 GCompare f
191 => (forall a. f a -> These (g a) (h a) -> i a)
192 -> DMap f g
193 -> DMap f h
194 -> DMap f i
195combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)
196 where go :: [DSum f g] -> [DSum f h] -> [DSum f i]
197 go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs
198 go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs
199 go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of
200 GLT -> (gk :=> f gk (This gv)) : go gs' hs
201 GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'
202 GGT -> (hk :=> f hk (That hv)) : go gs hs'
204-- | Extract the values of a 'DMap' of 'EitherTag's.
205dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)
206dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
207 (Nothing, Nothing) -> Nothing
208 (Just (Identity a), Nothing) -> Just $ This a
209 (Nothing, Just (Identity b)) -> Just $ That b
210 (Just (Identity a), Just (Identity b)) -> Just $ These a b
212-- | Tag type for 'Either' to use it as a 'DSum'.
213data EitherTag l r a where
214 LeftTag :: EitherTag l r l
215 RightTag :: EitherTag l r r
216 deriving (Typeable)
218deriving instance Show (EitherTag l r a)
219deriving instance Eq (EitherTag l r a)
220deriving instance Ord (EitherTag l r a)
222#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
223instance {-# INCOHERENT #-} (Show (f l), Show (f r)) => ShowTag (EitherTag l r) f where
224 showTagToShow e _ = case e of
225 LeftTag -> id
226 RightTag -> id
228instance {-# INCOHERENT #-} (Eq (f l), Eq (f r)) => EqTag (EitherTag l r) f where
229 eqTagToEq e _ = case e of
230 LeftTag -> id
231 RightTag -> id
232#endif
234instance GEq (EitherTag l r) where
235#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
236 geqToEq _ = id
237 geqUnify LeftTag LeftTag _ same = same
238 geqUnify RightTag RightTag _ same = same
239 geqUnify _ _ unknown _ = unknown
240#endif
241 geq a b = case (a, b) of
242 (LeftTag, LeftTag) -> Just Refl
243 (RightTag, RightTag) -> Just Refl
244 _ -> Nothing
246instance GCompare (EitherTag l r) where
247#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
248 gcompareToOrd _ = id
249#endif
250 gcompare a b = case (a, b) of
251 (LeftTag, LeftTag) -> GEQ
252 (LeftTag, RightTag) -> GLT
253 (RightTag, LeftTag) -> GGT
254 (RightTag, RightTag) -> GEQ
256instance GShow (EitherTag l r) where
257#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
258 gshowToShow _ = id
259#else
260 gshowsPrec _ a = case a of
261 LeftTag -> showString "LeftTag"
262 RightTag -> showString "RightTag"
263#endif
265instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where
266#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
267 showTagToShow t _ = case t of
268 LeftTag -> id
269 RightTag -> id
270#else
271 showTaggedPrec t n (Identity a) = case t of
272 LeftTag -> showsPrec n a
273 RightTag -> showsPrec n a
274#endif
276-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
277eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
278eitherToDSum = \case
279 Left a -> (LeftTag :=> Identity a)
280 Right b -> (RightTag :=> Identity b)
282-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
283dsumToEither :: DSum (EitherTag a b) Identity -> Either a b
284dsumToEither = \case
285 (LeftTag :=> Identity a) -> Left a
286 (RightTag :=> Identity b) -> Right b
288--------------------------------------------------------------------------------
289-- ComposeMaybe
290--------------------------------------------------------------------------------
292-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
293-- make the 'f' parameter have a nominal type role. We need f to be
294-- representational so that we can use safe 'coerce'.
295#if MIN_VERSION_transformers(5,2,0)
296newtype ComposeMaybe f a =
297#else
298newtype ComposeMaybe (f :: * -> *) (a :: *) =
299#endif
300 ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)
302deriving instance Functor f => Functor (ComposeMaybe f)
304#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
305instance {-# INCOHERENT #-} EqTag f g => EqTag f (ComposeMaybe g) where
306 eqTagToEq f _ = eqTagToEq f (Proxy :: Proxy g)
308instance {-# INCOHERENT #-} GShow k => ShowTag k (ComposeMaybe k) where
309 showTagToShow k _ r = gshowToShow k (showTagToShow k (Proxy :: Proxy k) r)
310#endif
311--------------------------------------------------------------------------------
312-- Deprecated functions
313--------------------------------------------------------------------------------
315{-# INLINE sequenceDmap #-}
316{-# DEPRECATED sequenceDmap "Use 'Data.Dependent.Map.traverseWithKey (\\_ -> fmap Identity)' instead" #-}
317-- | Run the actions contained in the 'DMap'
318sequenceDmap :: Applicative t => DMap f t -> t (DMap f Identity)
319sequenceDmap = DMap.traverseWithKey $ \_ t -> Identity <$> t
321{-# DEPRECATED wrapDMap "Use 'Data.Dependent.Map.map (f . runIdentity)' instead" #-}
322-- | Replace the 'Identity' functor for a 'DMap''s values with a different functor
323wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f
324wrapDMap f = DMap.map $ f . runIdentity
326{-# DEPRECATED rewrapDMap "Use 'Data.Dependent.Map.map' instead" #-}
327-- | Replace one functor for a 'DMap''s values with a different functor
328rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g
329rewrapDMap = DMap.map
331{-# DEPRECATED unwrapDMap "Use 'Data.Dependent.Map.map (Identity . f)' instead" #-}
332-- | Replace one functor for a 'DMap''s values with the 'Identity' functor
333unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity
334unwrapDMap f = DMap.map $ Identity . f
336{-# DEPRECATED unwrapDMapMaybe "Use 'Data.Dependent.Map.mapMaybeWithKey (\\_ a -> fmap Identity $ f a)' instead" #-}
337-- | Like 'unwrapDMap', but possibly delete some values from the DMap
338unwrapDMapMaybe :: GCompare k => (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity
339unwrapDMapMaybe f = DMap.mapMaybeWithKey $ \_ a -> Identity <$> f a
341{-# DEPRECATED extractFunctorDMap "Use 'mapKeyValuePairsMonotonic (\\(Const2 k :=> Identity v) -> Const2 k :=> v)' instead" #-}
342-- | Eliminate the 'Identity' functor in a 'DMap' and replace it with the
343-- underlying functor
344extractFunctorDMap :: DMap (Const2 k (f v)) Identity -> DMap (Const2 k v) f
345extractFunctorDMap = mapKeyValuePairsMonotonic $ \(Const2 k :=> Identity v) -> Const2 k :=> v