src/Data/Functor/Misc.hs · patch

git.iko.soy/patch

on aa-example help sign in

patch/src/Data/Functor/Misc.hs

232 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 PatternSynonyms #-}

10{-# LANGUAGE PolyKinds #-}

11{-# LANGUAGE RankNTypes #-}

12{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE StandaloneDeriving #-}

14-- | This module provides types and functions with no particular theme, but

15-- which are relevant to the use of 'Functor'-based datastructures like

16-- 'Data.Dependent.Map.DMap'.

17module Data.Functor.Misc

18 ( -- * Const2

19 Const2 (..)

20 , unConst2

21 , dmapToMap

22 , dmapToIntMap

23 , dmapToMapWith

24 , mapToDMap

25 , weakenDMapWith

26 -- * WrapArg

27 , WrapArg (..)

28 -- * Convenience functions for DMap

29 , mapWithFunctorToDMap

30 , intMapWithFunctorToDMap

31 , mapKeyValuePairsMonotonic

32 , combineDMapsWithKey

33 , EitherTag (..)

34 , dmapToThese

35 , eitherToDSum

36 , dsumToEither

37 , ComposeMaybe (..)

38 ) where

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

41import Data.Dependent.Map (DMap)

42import qualified Data.Dependent.Map as DMap

43import Data.Dependent.Sum

44import Data.Functor.Identity

45import Data.GADT.Compare

46import Data.GADT.Show

47import Data.IntMap (IntMap)

48import qualified Data.IntMap as IntMap

49import Data.Map (Map)

50import qualified Data.Map as Map

51import Data.Some (Some(Some))

52import Data.These

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

54import Data.Typeable hiding (Refl)

56--------------------------------------------------------------------------------

57-- Const2

58--------------------------------------------------------------------------------

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

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

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

63 Const2 :: k -> Const2 k v v

64 deriving (Typeable)

66-- | Extract the value from a Const2

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

68unConst2 (Const2 k) = k

70deriving instance Eq k => Eq (Const2 k v v')

71deriving instance Ord k => Ord (Const2 k v v')

72deriving instance Show k => Show (Const2 k v v')

73deriving instance Read k => Read (Const2 k v v)

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

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

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

79 geq (Const2 a) (Const2 b) =

80 if a == b

81 then Just Refl

82 else Nothing

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

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

86 LT -> GLT

87 EQ -> GEQ

88 GT -> GGT

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

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

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

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

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

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

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

99-- the wrapping 'Functor'

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

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

102

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

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

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

106

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

108-- to a 'DMap'

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

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

111

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

113-- functor, to a 'DMap'

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

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

116

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

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

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

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

121

122--------------------------------------------------------------------------------

123-- WrapArg

124--------------------------------------------------------------------------------

125

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

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

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

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

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

131

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

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

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

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

136

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

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

139

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

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

142 GLT -> GLT

143 GEQ -> GEQ

144 GGT -> GGT

145

146--------------------------------------------------------------------------------

147-- Convenience functions for DMap

148--------------------------------------------------------------------------------

149

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

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

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

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

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

155

156{-# INLINE combineDMapsWithKey #-}

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

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

159combineDMapsWithKey :: forall f g h i.

160 GCompare f

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

162 -> DMap f g

163 -> DMap f h

164 -> DMap f i

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

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

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

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

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

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

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

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

173

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

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

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

177 (Nothing, Nothing) -> Nothing

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

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

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

181

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

183data EitherTag l r a where

184 LeftTag :: EitherTag l r l

185 RightTag :: EitherTag l r r

186 deriving (Typeable)

187

188deriving instance Show (EitherTag l r a)

189deriving instance Eq (EitherTag l r a)

190deriving instance Ord (EitherTag l r a)

191

192instance GEq (EitherTag l r) where

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

194 (LeftTag, LeftTag) -> Just Refl

195 (RightTag, RightTag) -> Just Refl

196 _ -> Nothing

197

198instance GCompare (EitherTag l r) where

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

200 (LeftTag, LeftTag) -> GEQ

201 (LeftTag, RightTag) -> GLT

202 (RightTag, LeftTag) -> GGT

203 (RightTag, RightTag) -> GEQ

204

205instance GShow (EitherTag l r) where

206 gshowsPrec _ a = case a of

207 LeftTag -> showString "LeftTag"

208 RightTag -> showString "RightTag"

209

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

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

212eitherToDSum = \case

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

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

215

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

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

218dsumToEither = \case

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

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

221

222--------------------------------------------------------------------------------

223-- ComposeMaybe

224--------------------------------------------------------------------------------

225

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

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

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

229newtype ComposeMaybe f a =

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

231

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