git.iko.soy/patch
on dpatch-map-inner-patch help sign in
patch/src/Data/Functor/Misc.hs
254 lines 9.4 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveTraversable #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE LambdaCase #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE StandaloneDeriving #-}
13-- | This module provides types and functions with no particular theme, but
14-- which are relevant to the use of 'Functor'-based datastructures like
15-- 'Data.Dependent.Map.DMap'.
16module Data.Functor.Misc
17 ( -- * Const2
18 Const2 (..)
19 , Proxy3 (..)
20 , First2 (..)
21 , unConst2
22 , dmapToMap
23 , dmapToIntMap
24 , dmapToMapWith
25 , mapToDMap
26 , weakenDMapWith
27 -- * WrapArg
28 , WrapArg (..)
29 -- * Convenience functions for DMap
30 , mapWithFunctorToDMap
31 , intMapWithFunctorToDMap
32 , mapKeyValuePairsMonotonic
33 , combineDMapsWithKey
34 , EitherTag (..)
35 , dmapToThese
36 , eitherToDSum
37 , dsumToEither
38 , ComposeMaybe (..)
39 ) where
41import qualified Control.Category as Cat
42import Control.Applicative ((<$>))
43import Data.Dependent.Map (DMap)
44import qualified Data.Dependent.Map as DMap
45import Data.Dependent.Sum
46import Data.Functor.Identity
47import Data.GADT.Compare
48import Data.GADT.Show
49import Data.IntMap (IntMap)
50import qualified Data.IntMap as IntMap
51import Data.Map (Map)
52import qualified Data.Map as Map
53import qualified Data.Semigroupoid as Cat
54import Data.Some (Some, mkSome)
55import Data.These
56import Data.Type.Equality ((:~:)(Refl))
57import Data.Typeable hiding (Refl)
59--------------------------------------------------------------------------------
60-- Const2
61--------------------------------------------------------------------------------
63-- | 'Const2' stores a value of a given type 'k' and ensures that a particular
64-- type 'v' is always given for the last type parameter
65data Const2 :: * -> x -> x -> * where
66 Const2 :: k -> Const2 k v v
67 deriving (Typeable)
69deriving instance Eq k => Eq (Const2 k v v')
70deriving instance Ord k => Ord (Const2 k v v')
71deriving instance Show k => Show (Const2 k v v')
72deriving instance Read k => Read (Const2 k v v)
74-- | Extract the value from a Const2
75unConst2 :: Const2 k v v' -> k
76unConst2 (Const2 k) = k
78instance Show k => GShow (Const2 k v) where
79 gshowsPrec n x@(Const2 _) = showsPrec n x
81instance Eq k => GEq (Const2 k v) where
82 geq (Const2 a) (Const2 b) =
83 if a == b
84 then Just Refl
85 else Nothing
87instance Ord k => GCompare (Const2 k v) where
88 gcompare (Const2 a) (Const2 b) = case compare a b of
89 LT -> GLT
90 EQ -> GEQ
91 GT -> GGT
93data Proxy3 :: x -> y -> z -> * where
94 Proxy3 :: Proxy3 vx vy vz
95 deriving ( Show, Read, Eq, Ord
96 , Functor, Foldable, Traversable
97 , Typeable
98 )
100instance Cat.Category (Proxy3 x) where
101 id = Proxy3
102 ~Proxy3 . ~Proxy3 = Proxy3
104newtype First2 (t :: k -> *) (a :: k) (b :: k) = First2 (t b)
105 deriving ( Show, Read, Eq, Ord
106 , Functor, Foldable, Traversable
107 )
109instance Cat.Semigroupoid (First2 x) where
110 First2 x `o` ~(First2 _) = First2 x
112-- | Convert a 'DMap' to a regular 'Map'
113dmapToMap :: DMap (Const2 k v) Identity -> Map k v
114dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
116-- | Convert a 'DMap' to an 'IntMap'
117dmapToIntMap :: DMap (Const2 IntMap.Key v) Identity -> IntMap v
118dmapToIntMap = IntMap.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
120-- | Convert a 'DMap' to a regular 'Map', applying the given function to remove
121-- the wrapping 'Functor'
122dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v'
123dmapToMapWith f = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, f v)) . DMap.toAscList
125-- | Convert a regular 'Map' to a 'DMap'
126mapToDMap :: Map k v -> DMap (Const2 k v) Identity
127mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList
129-- | Convert a regular 'Map', where the values are already wrapped in a functor,
130-- to a 'DMap'
131mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f
132mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList
134-- | Convert a regular 'IntMap', where the values are already wrapped in a
135-- functor, to a 'DMap'
136intMapWithFunctorToDMap :: IntMap (f v) -> DMap (Const2 IntMap.Key v) f
137intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . IntMap.toAscList
139-- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with
140-- the keys, using a function to remove the wrapping 'Functor'
141weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'
142weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (mkSome 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 geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b
162instance GCompare f => GCompare (WrapArg g f) where
163 gcompare (WrapArg a) (WrapArg b) = case gcompare a b of
164 GLT -> GLT
165 GEQ -> GEQ
166 GGT -> GGT
168--------------------------------------------------------------------------------
169-- Convenience functions for DMap
170--------------------------------------------------------------------------------
172-- | Map over all key/value pairs in a 'DMap', potentially altering the key as
173-- well as the value. The provided function MUST preserve the ordering of the
174-- keys, or the resulting 'DMap' will be malformed.
175mapKeyValuePairsMonotonic :: (DSum k v -> DSum k' v') -> DMap k v -> DMap k' v'
176mapKeyValuePairsMonotonic f = DMap.fromDistinctAscList . map f . DMap.toAscList
178{-# INLINE combineDMapsWithKey #-}
179-- | Union two 'DMap's of different types, yielding another type. Each key that
180-- is present in either input map will be present in the output.
181combineDMapsWithKey :: forall f g h i.
182 GCompare f
183 => (forall a. f a -> These (g a) (h a) -> i a)
184 -> DMap f g
185 -> DMap f h
186 -> DMap f i
187combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)
188 where go :: [DSum f g] -> [DSum f h] -> [DSum f i]
189 go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs
190 go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs
191 go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of
192 GLT -> (gk :=> f gk (This gv)) : go gs' hs
193 GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'
194 GGT -> (hk :=> f hk (That hv)) : go gs hs'
196-- | Extract the values of a 'DMap' of 'EitherTag's.
197dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)
198dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
199 (Nothing, Nothing) -> Nothing
200 (Just (Identity a), Nothing) -> Just $ This a
201 (Nothing, Just (Identity b)) -> Just $ That b
202 (Just (Identity a), Just (Identity b)) -> Just $ These a b
204-- | Tag type for 'Either' to use it as a 'DSum'.
205data EitherTag l r a where
206 LeftTag :: EitherTag l r l
207 RightTag :: EitherTag l r r
208 deriving (Typeable)
210deriving instance Show (EitherTag l r a)
211deriving instance Eq (EitherTag l r a)
212deriving instance Ord (EitherTag l r a)
214instance GEq (EitherTag l r) where
215 geq a b = case (a, b) of
216 (LeftTag, LeftTag) -> Just Refl
217 (RightTag, RightTag) -> Just Refl
218 _ -> Nothing
220instance GCompare (EitherTag l r) where
221 gcompare a b = case (a, b) of
222 (LeftTag, LeftTag) -> GEQ
223 (LeftTag, RightTag) -> GLT
224 (RightTag, LeftTag) -> GGT
225 (RightTag, RightTag) -> GEQ
227instance GShow (EitherTag l r) where
228 gshowsPrec _ a = case a of
229 LeftTag -> showString "LeftTag"
230 RightTag -> showString "RightTag"
232-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
233eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
234eitherToDSum = \case
235 Left a -> (LeftTag :=> Identity a)
236 Right b -> (RightTag :=> Identity b)
238-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
239dsumToEither :: DSum (EitherTag a b) Identity -> Either a b
240dsumToEither = \case
241 (LeftTag :=> Identity a) -> Left a
242 (RightTag :=> Identity b) -> Right b
244--------------------------------------------------------------------------------
245-- ComposeMaybe
246--------------------------------------------------------------------------------
248-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
249-- make the 'f' parameter have a nominal type role. We need f to be
250-- representational so that we can use safe 'coerce'.
251newtype ComposeMaybe f a =
252 ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)
254deriving instance Functor f => Functor (ComposeMaybe f)