git.iko.soy/patch
on bc216da help sign in
patch/src/Data/Functor/Misc.hs
287 lines 11 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 , dmapToIntMap
27 , dmapToMapWith
28 , mapToDMap
29 , weakenDMapWith
30 -- * WrapArg
31 , WrapArg (..)
32 -- * Convenience functions for DMap
33 , mapWithFunctorToDMap
34 , intMapWithFunctorToDMap
35 , mapKeyValuePairsMonotonic
36 , combineDMapsWithKey
37 , EitherTag (..)
38 , dmapToThese
39 , eitherToDSum
40 , dsumToEither
41 -- * Deprecated functions
42 , sequenceDmap
43 , wrapDMap
44 , rewrapDMap
45 , unwrapDMap
46 , unwrapDMapMaybe
47 , extractFunctorDMap
48 , ComposeMaybe (..)
49 ) where
51import Control.Applicative (Applicative, (<$>))
52import Control.Monad.Identity
53import Data.Dependent.Map (DMap)
54import qualified Data.Dependent.Map as DMap
55import Data.Dependent.Sum
56import Data.GADT.Compare
57import Data.GADT.Show
58import Data.IntMap (IntMap)
59import qualified Data.IntMap as IntMap
60import Data.Map (Map)
61import qualified Data.Map as Map
62import Data.Some (Some)
63import qualified Data.Some as Some
64import Data.These
65import Data.Typeable hiding (Refl)
67--------------------------------------------------------------------------------
68-- Const2
69--------------------------------------------------------------------------------
71-- | 'Const2' stores a value of a given type 'k' and ensures that a particular
72-- type 'v' is always given for the last type parameter
73data Const2 :: * -> x -> x -> * where
74 Const2 :: k -> Const2 k v v
75 deriving (Typeable)
77-- | Extract the value from a Const2
78unConst2 :: Const2 k v v' -> k
79unConst2 (Const2 k) = k
81deriving instance Eq k => Eq (Const2 k v v')
82deriving instance Ord k => Ord (Const2 k v v')
83deriving instance Show k => Show (Const2 k v v')
84deriving instance Read k => Read (Const2 k v v)
86instance Show k => GShow (Const2 k v) where
87 gshowsPrec n x@(Const2 _) = showsPrec n x
89instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where
90 showTaggedPrec (Const2 _) = showsPrec
92instance Eq k => GEq (Const2 k v) where
93 geq (Const2 a) (Const2 b) =
94 if a == b
95 then Just Refl
96 else Nothing
98instance Ord k => GCompare (Const2 k v) where
99 gcompare (Const2 a) (Const2 b) = case compare a b of
100 LT -> GLT
101 EQ -> GEQ
102 GT -> GGT
104-- | Convert a 'DMap' to a regular 'Map'
105dmapToMap :: DMap (Const2 k v) Identity -> Map k v
106dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
108-- | Convert a 'DMap' to an 'IntMap'
109dmapToIntMap :: DMap (Const2 IntMap.Key v) Identity -> IntMap v
110dmapToIntMap = IntMap.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
112-- | Convert a 'DMap' to a regular 'Map', applying the given function to remove
113-- the wrapping 'Functor'
114dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v'
115dmapToMapWith f = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, f v)) . DMap.toAscList
117-- | Convert a regular 'Map' to a 'DMap'
118mapToDMap :: Map k v -> DMap (Const2 k v) Identity
119mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList
121-- | Convert a regular 'Map', where the values are already wrapped in a functor,
122-- to a 'DMap'
123mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f
124mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList
126-- | Convert a regular 'IntMap', where the values are already wrapped in a
127-- functor, to a 'DMap'
128intMapWithFunctorToDMap :: IntMap (f v) -> DMap (Const2 IntMap.Key v) f
129intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . IntMap.toAscList
131-- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with
132-- the keys, using a function to remove the wrapping 'Functor'
133weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'
134weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some.This k, f v)) . DMap.toAscList
136--------------------------------------------------------------------------------
137-- WrapArg
138--------------------------------------------------------------------------------
140-- | 'WrapArg' can be used to tag a value in one functor with a type
141-- representing another functor. This was primarily used with dependent-map <
142-- 0.2, in which the value type was not wrapped in a separate functor.
143data WrapArg :: (k -> *) -> (k -> *) -> * -> * where
144 WrapArg :: f a -> WrapArg g f (g a)
146deriving instance Eq (f a) => Eq (WrapArg g f (g' a))
147deriving instance Ord (f a) => Ord (WrapArg g f (g' a))
148deriving instance Show (f a) => Show (WrapArg g f (g' a))
149deriving instance Read (f a) => Read (WrapArg g f (g a))
151instance GEq f => GEq (WrapArg g f) where
152 geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b
154instance GCompare f => GCompare (WrapArg g f) where
155 gcompare (WrapArg a) (WrapArg b) = case gcompare a b of
156 GLT -> GLT
157 GEQ -> GEQ
158 GGT -> GGT
160--------------------------------------------------------------------------------
161-- Convenience functions for DMap
162--------------------------------------------------------------------------------
164-- | Map over all key/value pairs in a 'DMap', potentially altering the key as
165-- well as the value. The provided function MUST preserve the ordering of the
166-- keys, or the resulting 'DMap' will be malformed.
167mapKeyValuePairsMonotonic :: (DSum k v -> DSum k' v') -> DMap k v -> DMap k' v'
168mapKeyValuePairsMonotonic f = DMap.fromDistinctAscList . map f . DMap.toAscList
170{-# INLINE combineDMapsWithKey #-}
171-- | Union two 'DMap's of different types, yielding another type. Each key that
172-- is present in either input map will be present in the output.
173combineDMapsWithKey :: forall f g h i.
174 GCompare f
175 => (forall a. f a -> These (g a) (h a) -> i a)
176 -> DMap f g
177 -> DMap f h
178 -> DMap f i
179combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)
180 where go :: [DSum f g] -> [DSum f h] -> [DSum f i]
181 go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs
182 go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs
183 go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of
184 GLT -> (gk :=> f gk (This gv)) : go gs' hs
185 GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'
186 GGT -> (hk :=> f hk (That hv)) : go gs hs'
188-- | Extract the values of a 'DMap' of 'EitherTag's.
189dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)
190dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
191 (Nothing, Nothing) -> Nothing
192 (Just (Identity a), Nothing) -> Just $ This a
193 (Nothing, Just (Identity b)) -> Just $ That b
194 (Just (Identity a), Just (Identity b)) -> Just $ These a b
196-- | Tag type for 'Either' to use it as a 'DSum'.
197data EitherTag l r a where
198 LeftTag :: EitherTag l r l
199 RightTag :: EitherTag l r r
200 deriving (Typeable)
202deriving instance Show (EitherTag l r a)
203deriving instance Eq (EitherTag l r a)
204deriving instance Ord (EitherTag l r a)
206instance GEq (EitherTag l r) where
207 geq a b = case (a, b) of
208 (LeftTag, LeftTag) -> Just Refl
209 (RightTag, RightTag) -> Just Refl
210 _ -> Nothing
212instance GCompare (EitherTag l r) where
213 gcompare a b = case (a, b) of
214 (LeftTag, LeftTag) -> GEQ
215 (LeftTag, RightTag) -> GLT
216 (RightTag, LeftTag) -> GGT
217 (RightTag, RightTag) -> GEQ
219instance GShow (EitherTag l r) where
220 gshowsPrec _ a = case a of
221 LeftTag -> showString "LeftTag"
222 RightTag -> showString "RightTag"
224instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where
225 showTaggedPrec t n (Identity a) = case t of
226 LeftTag -> showsPrec n a
227 RightTag -> showsPrec n a
229-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
230eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
231eitherToDSum = \case
232 Left a -> (LeftTag :=> Identity a)
233 Right b -> (RightTag :=> Identity b)
235-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
236dsumToEither :: DSum (EitherTag a b) Identity -> Either a b
237dsumToEither = \case
238 (LeftTag :=> Identity a) -> Left a
239 (RightTag :=> Identity b) -> Right b
241--------------------------------------------------------------------------------
242-- ComposeMaybe
243--------------------------------------------------------------------------------
245-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
246-- make the 'f' parameter have a nominal type role. We need f to be
247-- representational so that we can use safe 'coerce'.
248newtype ComposeMaybe f a =
249 ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)
251deriving instance Functor f => Functor (ComposeMaybe f)
253--------------------------------------------------------------------------------
254-- Deprecated functions
255--------------------------------------------------------------------------------
257{-# INLINE sequenceDmap #-}
258{-# DEPRECATED sequenceDmap "Use 'Data.Dependent.Map.traverseWithKey (\\_ -> fmap Identity)' instead" #-}
259-- | Run the actions contained in the 'DMap'
260sequenceDmap :: Applicative t => DMap f t -> t (DMap f Identity)
261sequenceDmap = DMap.traverseWithKey $ \_ t -> Identity <$> t
263{-# DEPRECATED wrapDMap "Use 'Data.Dependent.Map.map (f . runIdentity)' instead" #-}
264-- | Replace the 'Identity' functor for a 'DMap''s values with a different functor
265wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f
266wrapDMap f = DMap.map $ f . runIdentity
268{-# DEPRECATED rewrapDMap "Use 'Data.Dependent.Map.map' instead" #-}
269-- | Replace one functor for a 'DMap''s values with a different functor
270rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g
271rewrapDMap = DMap.map
273{-# DEPRECATED unwrapDMap "Use 'Data.Dependent.Map.map (Identity . f)' instead" #-}
274-- | Replace one functor for a 'DMap''s values with the 'Identity' functor
275unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity
276unwrapDMap f = DMap.map $ Identity . f
278{-# DEPRECATED unwrapDMapMaybe "Use 'Data.Dependent.Map.mapMaybeWithKey (\\_ a -> fmap Identity $ f a)' instead" #-}
279-- | Like 'unwrapDMap', but possibly delete some values from the DMap
280unwrapDMapMaybe :: GCompare k => (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity
281unwrapDMapMaybe f = DMap.mapMaybeWithKey $ \_ a -> Identity <$> f a
283{-# DEPRECATED extractFunctorDMap "Use 'mapKeyValuePairsMonotonic (\\(Const2 k :=> Identity v) -> Const2 k :=> v)' instead" #-}
284-- | Eliminate the 'Identity' functor in a 'DMap' and replace it with the
285-- underlying functor
286extractFunctorDMap :: DMap (Const2 k (f v)) Identity -> DMap (Const2 k v) f
287extractFunctorDMap = mapKeyValuePairsMonotonic $ \(Const2 k :=> Identity v) -> Const2 k :=> v