{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Aeson.Schema.TH.Schema (schema) where
import Control.Monad (unless, (>=>))
import Data.Function (on)
import Data.Hashable (Hashable)
import qualified Data.HashMap.Strict as HashMap
import Data.List (nubBy)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Language.Haskell.TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Data.Aeson.Schema.Key (SchemaKey'(..), SchemaKeyV, fromSchemaKeyV)
import Data.Aeson.Schema.TH.Parse
(SchemaDef(..), SchemaDefObjItem(..), SchemaDefObjKey(..), parseSchemaDef)
import Data.Aeson.Schema.TH.Utils (reifySchema, schemaVToTypeQ)
import Data.Aeson.Schema.Type
( Schema'(..)
, SchemaObjectMapV
, SchemaType'(..)
, SchemaTypeV
, fromSchemaV
, showSchemaTypeV
)
import Data.Aeson.Schema.Utils.Invariant (unreachable)
import Data.Aeson.Schema.Utils.NameLike (NameLike(..))
schema :: QuasiQuoter
schema :: QuasiQuoter
schema = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = String -> String -> Q Exp
forall a. HasCallStack => String -> a
error String
"Cannot use `schema` for Exp"
, quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"Cannot use `schema` for Dec"
, quoteType :: String -> Q Type
quoteType = String -> Q SchemaDef
forall (m :: * -> *). MonadFail m => String -> m SchemaDef
parseSchemaDef (String -> Q SchemaDef)
-> (SchemaDef -> Q Type) -> String -> Q Type
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
SchemaDefObj NonEmpty SchemaDefObjItem
items -> NonEmpty SchemaDefObjItem -> Q Type
generateSchemaObject NonEmpty SchemaDefObjItem
items
SchemaDef
_ -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"`schema` definition must be an object"
, quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"Cannot use `schema` for Pat"
}
where
generateSchemaObject :: NonEmpty SchemaDefObjItem -> Q Type
generateSchemaObject NonEmpty SchemaDefObjItem
items = SchemaV -> Q Type
schemaVToTypeQ (SchemaV -> Q Type)
-> (SchemaObjectMap' String NameLike -> SchemaV)
-> SchemaObjectMap' String NameLike
-> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaObjectMap' String NameLike -> SchemaV
forall s ty. SchemaObjectMap' s ty -> Schema' s ty
Schema (SchemaObjectMap' String NameLike -> Q Type)
-> Q (SchemaObjectMap' String NameLike) -> Q Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NonEmpty SchemaDefObjItem -> Q (SchemaObjectMap' String NameLike)
generateSchemaObjectV NonEmpty SchemaDefObjItem
items
data KeySource = Provided | Imported
deriving (Int -> KeySource -> ShowS
[KeySource] -> ShowS
KeySource -> String
(Int -> KeySource -> ShowS)
-> (KeySource -> String)
-> ([KeySource] -> ShowS)
-> Show KeySource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeySource] -> ShowS
$cshowList :: [KeySource] -> ShowS
show :: KeySource -> String
$cshow :: KeySource -> String
showsPrec :: Int -> KeySource -> ShowS
$cshowsPrec :: Int -> KeySource -> ShowS
Show, KeySource -> KeySource -> Bool
(KeySource -> KeySource -> Bool)
-> (KeySource -> KeySource -> Bool) -> Eq KeySource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeySource -> KeySource -> Bool
$c/= :: KeySource -> KeySource -> Bool
== :: KeySource -> KeySource -> Bool
$c== :: KeySource -> KeySource -> Bool
Eq)
generateSchemaObjectV :: NonEmpty SchemaDefObjItem -> Q SchemaObjectMapV
generateSchemaObjectV :: NonEmpty SchemaDefObjItem -> Q (SchemaObjectMap' String NameLike)
generateSchemaObjectV NonEmpty SchemaDefObjItem
schemaDefObjItems = do
NonEmpty (SchemaObjectMap' String NameLike, KeySource)
schemaObjectMapsWithSource <- (SchemaDefObjItem
-> Q (SchemaObjectMap' String NameLike, KeySource))
-> NonEmpty SchemaDefObjItem
-> Q (NonEmpty (SchemaObjectMap' String NameLike, KeySource))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SchemaDefObjItem -> Q (SchemaObjectMap' String NameLike, KeySource)
getSchemaObjectMap NonEmpty SchemaDefObjItem
schemaDefObjItems
let schemaObjectMaps :: LookupMap SchemaKeyV (KeySource, SchemaTypeV)
schemaObjectMaps :: LookupMap SchemaKeyV (KeySource, SchemaTypeV)
schemaObjectMaps = ((SchemaObjectMap' String NameLike, KeySource)
-> LookupMap SchemaKeyV (KeySource, SchemaTypeV))
-> NonEmpty (SchemaObjectMap' String NameLike, KeySource)
-> LookupMap SchemaKeyV (KeySource, SchemaTypeV)
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((SchemaObjectMap' String NameLike
-> KeySource -> LookupMap SchemaKeyV (KeySource, SchemaTypeV))
-> (SchemaObjectMap' String NameLike, KeySource)
-> LookupMap SchemaKeyV (KeySource, SchemaTypeV)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SchemaObjectMap' String NameLike
-> KeySource -> LookupMap SchemaKeyV (KeySource, SchemaTypeV)
forall k v a. LookupMap k v -> a -> LookupMap k (a, v)
distribute) NonEmpty (SchemaObjectMap' String NameLike, KeySource)
schemaObjectMapsWithSource
(String -> Q (SchemaObjectMap' String NameLike))
-> (SchemaObjectMap' String NameLike
-> Q (SchemaObjectMap' String NameLike))
-> Either String (SchemaObjectMap' String NameLike)
-> Q (SchemaObjectMap' String NameLike)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Q (SchemaObjectMap' String NameLike)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail SchemaObjectMap' String NameLike
-> Q (SchemaObjectMap' String NameLike)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (SchemaObjectMap' String NameLike)
-> Q (SchemaObjectMap' String NameLike))
-> Either String (SchemaObjectMap' String NameLike)
-> Q (SchemaObjectMap' String NameLike)
forall a b. (a -> b) -> a -> b
$ LookupMap SchemaKeyV (KeySource, SchemaTypeV)
-> Either String (SchemaObjectMap' String NameLike)
forall a.
Show a =>
LookupMap SchemaKeyV (KeySource, a)
-> Either String (LookupMap SchemaKeyV a)
resolveKeys LookupMap SchemaKeyV (KeySource, SchemaTypeV)
schemaObjectMaps
getSchemaObjectMap :: SchemaDefObjItem -> Q (SchemaObjectMapV, KeySource)
getSchemaObjectMap :: SchemaDefObjItem -> Q (SchemaObjectMap' String NameLike, KeySource)
getSchemaObjectMap = \case
SchemaDefObjPair (SchemaDefObjKey
schemaDefKey, SchemaDef
schemaDefType) -> do
let schemaKey :: SchemaKeyV
schemaKey = SchemaDefObjKey -> SchemaKeyV
fromSchemaDefKey SchemaDefObjKey
schemaDefKey
SchemaTypeV
schemaType <- SchemaDef -> Q SchemaTypeV
fromSchemaDefType SchemaDef
schemaDefType
case SchemaKeyV
schemaKey of
PhantomKey String
_ ->
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SchemaTypeV -> Bool
forall s ty. SchemaType' s ty -> Bool
isValidPhantomSchema SchemaTypeV
schemaType) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid schema for '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaKeyV -> String
fromSchemaKeyV SchemaKeyV
schemaKey String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"': " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV SchemaTypeV
schemaType
SchemaKeyV
_ -> () -> Q ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(SchemaObjectMap' String NameLike, KeySource)
-> Q (SchemaObjectMap' String NameLike, KeySource)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(SchemaKeyV
schemaKey, SchemaTypeV
schemaType)], KeySource
Provided)
SchemaDefObjExtend String
other -> do
SchemaV
schemaV <- String -> Q SchemaV
reifySchema String
other
(SchemaObjectMap' String NameLike, KeySource)
-> Q (SchemaObjectMap' String NameLike, KeySource)
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemaV -> SchemaObjectMap' String NameLike
fromSchemaV SchemaV
schemaV, KeySource
Imported)
where
isValidPhantomSchema :: SchemaType' s ty -> Bool
isValidPhantomSchema = \case
SchemaMaybe SchemaType' s ty
inner -> SchemaType' s ty -> Bool
isValidPhantomSchema SchemaType' s ty
inner
SchemaTry SchemaType' s ty
_ -> Bool
True
SchemaUnion [SchemaType' s ty]
schemas -> (SchemaType' s ty -> Bool) -> [SchemaType' s ty] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SchemaType' s ty -> Bool
isValidPhantomSchema [SchemaType' s ty]
schemas
SchemaObject SchemaObjectMap' s ty
_ -> Bool
True
SchemaInclude Either ty (Schema' s ty)
_ -> Bool
True
SchemaType' s ty
_ -> Bool
False
resolveKeys :: Show a => LookupMap SchemaKeyV (KeySource, a) -> Either String (LookupMap SchemaKeyV a)
resolveKeys :: LookupMap SchemaKeyV (KeySource, a)
-> Either String (LookupMap SchemaKeyV a)
resolveKeys = ((SchemaKeyV, [(KeySource, a)]) -> Either String (SchemaKeyV, a))
-> [(SchemaKeyV, [(KeySource, a)])]
-> Either String (LookupMap SchemaKeyV a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SchemaKeyV -> [(KeySource, a)] -> Either String (SchemaKeyV, a))
-> (SchemaKeyV, [(KeySource, a)]) -> Either String (SchemaKeyV, a)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SchemaKeyV -> [(KeySource, a)] -> Either String (SchemaKeyV, a)
forall b.
Show b =>
SchemaKeyV -> [(KeySource, b)] -> Either String (SchemaKeyV, b)
resolveKey) ([(SchemaKeyV, [(KeySource, a)])]
-> Either String (LookupMap SchemaKeyV a))
-> (LookupMap SchemaKeyV (KeySource, a)
-> [(SchemaKeyV, [(KeySource, a)])])
-> LookupMap SchemaKeyV (KeySource, a)
-> Either String (LookupMap SchemaKeyV a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SchemaKeyV -> String)
-> LookupMap SchemaKeyV (KeySource, a)
-> [(SchemaKeyV, [(KeySource, a)])]
forall a k v.
(Eq a, Hashable a) =>
(k -> a) -> LookupMap k v -> LookupMap k [v]
groupByKeyWith SchemaKeyV -> String
fromSchemaKeyV
where
resolveKey :: SchemaKeyV -> [(KeySource, b)] -> Either String (SchemaKeyV, b)
resolveKey SchemaKeyV
key [(KeySource, b)]
sourcesAndVals =
let filterSource :: KeySource -> [b]
filterSource KeySource
source = ((KeySource, b) -> b) -> [(KeySource, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (KeySource, b) -> b
forall a b. (a, b) -> b
snd ([(KeySource, b)] -> [b]) -> [(KeySource, b)] -> [b]
forall a b. (a -> b) -> a -> b
$ ((KeySource, b) -> Bool) -> [(KeySource, b)] -> [(KeySource, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((KeySource -> KeySource -> Bool
forall a. Eq a => a -> a -> Bool
== KeySource
source) (KeySource -> Bool)
-> ((KeySource, b) -> KeySource) -> (KeySource, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeySource, b) -> KeySource
forall a b. (a, b) -> a
fst) [(KeySource, b)]
sourcesAndVals
numProvided :: Int
numProvided = [b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([b] -> Int) -> [b] -> Int
forall a b. (a -> b) -> a -> b
$ KeySource -> [b]
filterSource KeySource
Provided
numImported :: Int
numImported = [b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([b] -> Int) -> [b] -> Int
forall a b. (a -> b) -> a -> b
$ KeySource -> [b]
filterSource KeySource
Imported
in if
| Int
numProvided Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 -> String -> Either String (SchemaKeyV, b)
forall a b. a -> Either a b
Left (String -> Either String (SchemaKeyV, b))
-> String -> Either String (SchemaKeyV, b)
forall a b. (a -> b) -> a -> b
$ String
"Key '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaKeyV -> String
fromSchemaKeyV SchemaKeyV
key String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' specified multiple times"
| [b
val] <- KeySource -> [b]
filterSource KeySource
Provided -> (SchemaKeyV, b) -> Either String (SchemaKeyV, b)
forall a b. b -> Either a b
Right (SchemaKeyV
key, b
val)
| Int
numImported Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 -> String -> Either String (SchemaKeyV, b)
forall a b. a -> Either a b
Left (String -> Either String (SchemaKeyV, b))
-> String -> Either String (SchemaKeyV, b)
forall a b. (a -> b) -> a -> b
$ String
"Key '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaKeyV -> String
fromSchemaKeyV SchemaKeyV
key String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' declared in multiple imported schemas"
| [b
val] <- KeySource -> [b]
filterSource KeySource
Imported -> (SchemaKeyV, b) -> Either String (SchemaKeyV, b)
forall a b. b -> Either a b
Right (SchemaKeyV
key, b
val)
| Bool
otherwise -> String -> Either String (SchemaKeyV, b)
forall a. String -> a
unreachable (String -> Either String (SchemaKeyV, b))
-> String -> Either String (SchemaKeyV, b)
forall a b. (a -> b) -> a -> b
$ String
"resolveKey received: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (SchemaKeyV, [(KeySource, b)]) -> String
forall a. Show a => a -> String
show (SchemaKeyV
key, [(KeySource, b)]
sourcesAndVals)
fromSchemaDefKey :: SchemaDefObjKey -> SchemaKeyV
fromSchemaDefKey :: SchemaDefObjKey -> SchemaKeyV
fromSchemaDefKey = \case
SchemaDefObjKeyNormal String
key -> String -> SchemaKeyV
forall s. s -> SchemaKey' s
NormalKey String
key
SchemaDefObjKeyPhantom String
key -> String -> SchemaKeyV
forall s. s -> SchemaKey' s
PhantomKey String
key
fromSchemaDefType :: SchemaDef -> Q SchemaTypeV
fromSchemaDefType :: SchemaDef -> Q SchemaTypeV
fromSchemaDefType = \case
SchemaDefType String
name -> SchemaTypeV -> Q SchemaTypeV
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemaTypeV -> Q SchemaTypeV) -> SchemaTypeV -> Q SchemaTypeV
forall a b. (a -> b) -> a -> b
$ NameLike -> SchemaTypeV
forall s ty. ty -> SchemaType' s ty
SchemaScalar (NameLike -> SchemaTypeV) -> NameLike -> SchemaTypeV
forall a b. (a -> b) -> a -> b
$ String -> NameLike
NameRef String
name
SchemaDefMaybe SchemaDef
inner -> SchemaTypeV -> SchemaTypeV
forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaMaybe (SchemaTypeV -> SchemaTypeV) -> Q SchemaTypeV -> Q SchemaTypeV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaDef -> Q SchemaTypeV
fromSchemaDefType SchemaDef
inner
SchemaDefTry SchemaDef
inner -> SchemaTypeV -> SchemaTypeV
forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaTry (SchemaTypeV -> SchemaTypeV) -> Q SchemaTypeV -> Q SchemaTypeV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaDef -> Q SchemaTypeV
fromSchemaDefType SchemaDef
inner
SchemaDefList SchemaDef
inner -> SchemaTypeV -> SchemaTypeV
forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaList (SchemaTypeV -> SchemaTypeV) -> Q SchemaTypeV -> Q SchemaTypeV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaDef -> Q SchemaTypeV
fromSchemaDefType SchemaDef
inner
SchemaDefInclude String
other -> SchemaTypeV -> Q SchemaTypeV
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemaTypeV -> Q SchemaTypeV) -> SchemaTypeV -> Q SchemaTypeV
forall a b. (a -> b) -> a -> b
$ Either NameLike SchemaV -> SchemaTypeV
forall s ty. Either ty (Schema' s ty) -> SchemaType' s ty
SchemaInclude (Either NameLike SchemaV -> SchemaTypeV)
-> Either NameLike SchemaV -> SchemaTypeV
forall a b. (a -> b) -> a -> b
$ NameLike -> Either NameLike SchemaV
forall a b. a -> Either a b
Left (NameLike -> Either NameLike SchemaV)
-> NameLike -> Either NameLike SchemaV
forall a b. (a -> b) -> a -> b
$ String -> NameLike
NameRef String
other
SchemaDefUnion NonEmpty SchemaDef
schemas -> [SchemaTypeV] -> SchemaTypeV
forall s ty. [SchemaType' s ty] -> SchemaType' s ty
SchemaUnion ([SchemaTypeV] -> SchemaTypeV)
-> (NonEmpty SchemaTypeV -> [SchemaTypeV])
-> NonEmpty SchemaTypeV
-> SchemaTypeV
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty SchemaTypeV -> [SchemaTypeV]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty SchemaTypeV -> SchemaTypeV)
-> Q (NonEmpty SchemaTypeV) -> Q SchemaTypeV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SchemaDef -> Q SchemaTypeV)
-> NonEmpty SchemaDef -> Q (NonEmpty SchemaTypeV)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SchemaDef -> Q SchemaTypeV
fromSchemaDefType NonEmpty SchemaDef
schemas
SchemaDefObj NonEmpty SchemaDefObjItem
items -> SchemaObjectMap' String NameLike -> SchemaTypeV
forall s ty. SchemaObjectMap' s ty -> SchemaType' s ty
SchemaObject (SchemaObjectMap' String NameLike -> SchemaTypeV)
-> Q (SchemaObjectMap' String NameLike) -> Q SchemaTypeV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty SchemaDefObjItem -> Q (SchemaObjectMap' String NameLike)
generateSchemaObjectV NonEmpty SchemaDefObjItem
items
type LookupMap k v = [(k, v)]
distribute :: LookupMap k v -> a -> LookupMap k (a, v)
distribute :: LookupMap k v -> a -> LookupMap k (a, v)
distribute LookupMap k v
lookupMap a
a = ((k, v) -> (k, (a, v))) -> LookupMap k v -> LookupMap k (a, v)
forall a b. (a -> b) -> [a] -> [b]
map ((v -> (a, v)) -> (k, v) -> (k, (a, v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
a,)) LookupMap k v
lookupMap
groupByKeyWith :: (Eq a, Hashable a) => (k -> a) -> LookupMap k v -> LookupMap k [v]
groupByKeyWith :: (k -> a) -> LookupMap k v -> LookupMap k [v]
groupByKeyWith k -> a
f LookupMap k v
pairs = (k -> (k, [v])) -> [k] -> LookupMap k [v]
forall a b. (a -> b) -> [a] -> [b]
map (\k
key -> (k
key, HashMap a [v]
groups HashMap a [v] -> a -> [v]
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
HashMap.! k -> a
f k
key)) [k]
distinctKeys
where
distinctKeys :: [k]
distinctKeys = (k -> k -> Bool) -> [k] -> [k]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool) -> (k -> a) -> k -> k -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` k -> a
f) ([k] -> [k]) -> [k] -> [k]
forall a b. (a -> b) -> a -> b
$ ((k, v) -> k) -> LookupMap k v -> [k]
forall a b. (a -> b) -> [a] -> [b]
map (k, v) -> k
forall a b. (a, b) -> a
fst LookupMap k v
pairs
groups :: HashMap a [v]
groups = ([v] -> [v] -> [v]) -> [(a, [v])] -> HashMap a [v]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HashMap.fromListWith (([v] -> [v] -> [v]) -> [v] -> [v] -> [v]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [v] -> [v] -> [v]
forall a. [a] -> [a] -> [a]
(++)) ([(a, [v])] -> HashMap a [v]) -> [(a, [v])] -> HashMap a [v]
forall a b. (a -> b) -> a -> b
$ ((k, v) -> (a, [v])) -> LookupMap k v -> [(a, [v])]
forall a b. (a -> b) -> [a] -> [b]
map (\(k
k, v
v) -> (k -> a
f k
k, [v
v])) LookupMap k v
pairs