src/Data/Functor/Misc.hs · patch

git.iko.soy/patch

on develop help sign in

patch/src/Data/Functor/Misc.hs

231 lines 8.8 kB history raw

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE DeriveFunctor #-}

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 , unConst2

20 , dmapToMap

21 , dmapToIntMap

22 , dmapToMapWith

23 , mapToDMap

24 , weakenDMapWith

25 -- * WrapArg

26 , WrapArg (..)

27 -- * Convenience functions for DMap

28 , mapWithFunctorToDMap

29 , intMapWithFunctorToDMap

30 , mapKeyValuePairsMonotonic

31 , combineDMapsWithKey

32 , EitherTag (..)

33 , dmapToThese

34 , eitherToDSum

35 , dsumToEither

36 , ComposeMaybe (..)

37 ) where

39import Control.Applicative ((<$>))

40import Data.Dependent.Map (DMap)

41import qualified Data.Dependent.Map as DMap

42import Data.Dependent.Sum

43import Data.Functor.Identity

44import Data.GADT.Compare

45import Data.GADT.Show

46import Data.IntMap (IntMap)

47import qualified Data.IntMap as IntMap

48import Data.Map (Map)

49import qualified Data.Map as Map

50import Data.Some (Some, mkSome)

51import Data.These

52import Data.Type.Equality ((:~:)(Refl))

53import Data.Typeable hiding (Refl)

55--------------------------------------------------------------------------------

56-- Const2

57--------------------------------------------------------------------------------

59-- | 'Const2' stores a value of a given type 'k' and ensures that a particular

60-- type 'v' is always given for the last type parameter

61data Const2 :: * -> x -> x -> * where

62 Const2 :: k -> Const2 k v v

63 deriving (Typeable)

65-- | Extract the value from a Const2

66unConst2 :: Const2 k v v' -> k

67unConst2 (Const2 k) = k

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)

74instance Show k => GShow (Const2 k v) where

75 gshowsPrec n x@(Const2 _) = showsPrec n x

77instance Eq k => GEq (Const2 k v) where

78 geq (Const2 a) (Const2 b) =

79 if a == b

80 then Just Refl

81 else Nothing

83instance Ord k => GCompare (Const2 k v) where

84 gcompare (Const2 a) (Const2 b) = case compare a b of

85 LT -> GLT

86 EQ -> GEQ

87 GT -> GGT

89-- | Convert a 'DMap' to a regular 'Map'

90dmapToMap :: DMap (Const2 k v) Identity -> Map k v

91dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList

93-- | Convert a 'DMap' to an 'IntMap'

94dmapToIntMap :: DMap (Const2 IntMap.Key v) Identity -> IntMap v

95dmapToIntMap = IntMap.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList

97-- | Convert a 'DMap' to a regular 'Map', applying the given function to remove

98-- the wrapping 'Functor'

99dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v'

100dmapToMapWith f = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, f v)) . DMap.toAscList

101

102-- | Convert a regular 'Map' to a 'DMap'

103mapToDMap :: Map k v -> DMap (Const2 k v) Identity

104mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList

105

106-- | Convert a regular 'Map', where the values are already wrapped in a functor,

107-- to a 'DMap'

108mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f

109mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList

110

111-- | Convert a regular 'IntMap', where the values are already wrapped in a

112-- functor, to a 'DMap'

113intMapWithFunctorToDMap :: IntMap (f v) -> DMap (Const2 IntMap.Key v) f

114intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . IntMap.toAscList

115

116-- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with

117-- the keys, using a function to remove the wrapping 'Functor'

118weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'

119weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (mkSome k, f v)) . DMap.toAscList

120

121--------------------------------------------------------------------------------

122-- WrapArg

123--------------------------------------------------------------------------------

124

125-- | 'WrapArg' can be used to tag a value in one functor with a type

126-- representing another functor. This was primarily used with dependent-map <

127-- 0.2, in which the value type was not wrapped in a separate functor.

128data WrapArg :: (k -> *) -> (k -> *) -> * -> * where

129 WrapArg :: f a -> WrapArg g f (g a)

130

131deriving instance Eq (f a) => Eq (WrapArg g f (g' a))

132deriving instance Ord (f a) => Ord (WrapArg g f (g' a))

133deriving instance Show (f a) => Show (WrapArg g f (g' a))

134deriving instance Read (f a) => Read (WrapArg g f (g a))

135

136instance GEq f => GEq (WrapArg g f) where

137 geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b

138

139instance GCompare f => GCompare (WrapArg g f) where

140 gcompare (WrapArg a) (WrapArg b) = case gcompare a b of

141 GLT -> GLT

142 GEQ -> GEQ

143 GGT -> GGT

144

145--------------------------------------------------------------------------------

146-- Convenience functions for DMap

147--------------------------------------------------------------------------------

148

149-- | Map over all key/value pairs in a 'DMap', potentially altering the key as

150-- well as the value. The provided function MUST preserve the ordering of the

151-- keys, or the resulting 'DMap' will be malformed.

152mapKeyValuePairsMonotonic :: (DSum k v -> DSum k' v') -> DMap k v -> DMap k' v'

153mapKeyValuePairsMonotonic f = DMap.fromDistinctAscList . map f . DMap.toAscList

154

155{-# INLINE combineDMapsWithKey #-}

156-- | Union two 'DMap's of different types, yielding another type. Each key that

157-- is present in either input map will be present in the output.

158combineDMapsWithKey :: forall f g h i.

159 GCompare f

160 => (forall a. f a -> These (g a) (h a) -> i a)

161 -> DMap f g

162 -> DMap f h

163 -> DMap f i

164combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)

165 where go :: [DSum f g] -> [DSum f h] -> [DSum f i]

166 go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs

167 go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs

168 go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of

169 GLT -> (gk :=> f gk (This gv)) : go gs' hs

170 GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'

171 GGT -> (hk :=> f hk (That hv)) : go gs hs'

172

173-- | Extract the values of a 'DMap' of 'EitherTag's.

174dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)

175dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of

176 (Nothing, Nothing) -> Nothing

177 (Just (Identity a), Nothing) -> Just $ This a

178 (Nothing, Just (Identity b)) -> Just $ That b

179 (Just (Identity a), Just (Identity b)) -> Just $ These a b

180

181-- | Tag type for 'Either' to use it as a 'DSum'.

182data EitherTag l r a where

183 LeftTag :: EitherTag l r l

184 RightTag :: EitherTag l r r

185 deriving (Typeable)

186

187deriving instance Show (EitherTag l r a)

188deriving instance Eq (EitherTag l r a)

189deriving instance Ord (EitherTag l r a)

190

191instance GEq (EitherTag l r) where

192 geq a b = case (a, b) of

193 (LeftTag, LeftTag) -> Just Refl

194 (RightTag, RightTag) -> Just Refl

195 _ -> Nothing

196

197instance GCompare (EitherTag l r) where

198 gcompare a b = case (a, b) of

199 (LeftTag, LeftTag) -> GEQ

200 (LeftTag, RightTag) -> GLT

201 (RightTag, LeftTag) -> GGT

202 (RightTag, RightTag) -> GEQ

203

204instance GShow (EitherTag l r) where

205 gshowsPrec _ a = case a of

206 LeftTag -> showString "LeftTag"

207 RightTag -> showString "RightTag"

208

209-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.

210eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity

211eitherToDSum = \case

212 Left a -> (LeftTag :=> Identity a)

213 Right b -> (RightTag :=> Identity b)

214

215-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.

216dsumToEither :: DSum (EitherTag a b) Identity -> Either a b

217dsumToEither = \case

218 (LeftTag :=> Identity a) -> Left a

219 (RightTag :=> Identity b) -> Right b

220

221--------------------------------------------------------------------------------

222-- ComposeMaybe

223--------------------------------------------------------------------------------

224

225-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would

226-- make the 'f' parameter have a nominal type role. We need f to be

227-- representational so that we can use safe 'coerce'.

228newtype ComposeMaybe f a =

229 ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)

230

231deriving instance Functor f => Functor (ComposeMaybe f)