src/Data/Functor/Misc.hs · patch

git.iko.soy/patch

on c8ef082 help sign in

patch/src/Data/Functor/Misc.hs

234 lines 8.9 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#ifdef USE_REFLEX_OPTIMIZER

15{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

16#endif

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

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

19-- 'Data.Dependent.Map.DMap'.

20module Data.Functor.Misc

21 ( -- * Const2

22 Const2 (..)

23 , unConst2

24 , dmapToMap

25 , dmapToIntMap

26 , dmapToMapWith

27 , mapToDMap

28 , weakenDMapWith

29 -- * WrapArg

30 , WrapArg (..)

31 -- * Convenience functions for DMap

32 , mapWithFunctorToDMap

33 , intMapWithFunctorToDMap

34 , mapKeyValuePairsMonotonic

35 , combineDMapsWithKey

36 , EitherTag (..)

37 , dmapToThese

38 , eitherToDSum

39 , dsumToEither

40 , ComposeMaybe (..)

41 ) where

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

44import Control.Monad.Identity

45import Data.Dependent.Map (DMap)

46import qualified Data.Dependent.Map as DMap

47import Data.Dependent.Sum

48import Data.GADT.Compare

49import Data.GADT.Show

50import Data.IntMap (IntMap)

51import qualified Data.IntMap as IntMap

52import Data.Map (Map)

53import qualified Data.Map as Map

54import Data.Some (Some(Some))

55import Data.These

56import Data.Typeable hiding (Refl)

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

59-- Const2

60--------------------------------------------------------------------------------

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

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

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

65 Const2 :: k -> Const2 k v v

66 deriving (Typeable)

68-- | Extract the value from a Const2

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

70unConst2 (Const2 k) = k

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

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

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

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

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

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

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

81 geq (Const2 a) (Const2 b) =

82 if a == b

83 then Just Refl

84 else Nothing

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

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

88 LT -> GLT

89 EQ -> GEQ

90 GT -> GGT

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

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

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

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

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

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

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

101-- the wrapping 'Functor'

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

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

104

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

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

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

108

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

110-- to a 'DMap'

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

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

113

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

115-- functor, to a 'DMap'

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

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

118

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

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

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

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

123

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

125-- WrapArg

126--------------------------------------------------------------------------------

127

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

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

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

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

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

133

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

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

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

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

138

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

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

141

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

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

144 GLT -> GLT

145 GEQ -> GEQ

146 GGT -> GGT

147

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

149-- Convenience functions for DMap

150--------------------------------------------------------------------------------

151

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

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

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

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

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

157

158{-# INLINE combineDMapsWithKey #-}

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

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

161combineDMapsWithKey :: forall f g h i.

162 GCompare f

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

164 -> DMap f g

165 -> DMap f h

166 -> DMap f i

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

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

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

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

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

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

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

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

175

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

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

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

179 (Nothing, Nothing) -> Nothing

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

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

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

183

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

185data EitherTag l r a where

186 LeftTag :: EitherTag l r l

187 RightTag :: EitherTag l r r

188 deriving (Typeable)

189

190deriving instance Show (EitherTag l r a)

191deriving instance Eq (EitherTag l r a)

192deriving instance Ord (EitherTag l r a)

193

194instance GEq (EitherTag l r) where

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

196 (LeftTag, LeftTag) -> Just Refl

197 (RightTag, RightTag) -> Just Refl

198 _ -> Nothing

199

200instance GCompare (EitherTag l r) where

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

202 (LeftTag, LeftTag) -> GEQ

203 (LeftTag, RightTag) -> GLT

204 (RightTag, LeftTag) -> GGT

205 (RightTag, RightTag) -> GEQ

206

207instance GShow (EitherTag l r) where

208 gshowsPrec _ a = case a of

209 LeftTag -> showString "LeftTag"

210 RightTag -> showString "RightTag"

211

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

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

214eitherToDSum = \case

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

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

217

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

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

220dsumToEither = \case

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

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

223

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

225-- ComposeMaybe

226--------------------------------------------------------------------------------

227

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

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

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

231newtype ComposeMaybe f a =

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

233

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