1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
module Hakyll.Alias
( Aliased (..)
, ToAliases (..)
, FromAlias (..)
-- * Containers
, AliasMap (..)
, buildAliasMap
-- * Errors
, NoAlias (..)
, missingAlias
) where
import Prolog
import Data.Aeson
import Data.Aeson.KeyMap qualified as KM
import Data.HashMap.Strict qualified as HM
import Data.HashSet qualified as HS
data WithAliases a x = WithAliases (HS.HashSet a) x
deriving (Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)
instance Hashable a => Applicative (WithAliases a) where
pure = WithAliases mempty
WithAliases a1 f <*> WithAliases a2 x = WithAliases (a1 <> a2) (f x)
instance Comonad (WithAliases a) where
extract (WithAliases _ x) = x
duplicate = join (<$)
-- instance (FromJSON a, FromJSON x, Hashable a) => FromJSON (WithAliases a x) where
-- parseJSON (Object v) = WithAliases
-- <$> v .:? "aliases" .!= mempty
-- <*> (parseJSON (Object v) <|> v .: "value")
-- parseJSON v = WithAliases mempty <$> parseJSON v
-- instance (ToJSON a, ToJSON x) => ToJSON (WithAliases a x) where
-- toJSON (WithAliases a x)
-- | HS.null a = toJSON x
-- | otherwise = case toJSON x of
-- Object o -> Object $ KM.singleton "aliases" (toJSON a) <> o
-- v -> object
-- [ "aliases" .= a
-- , "value" .= v
-- ]
-- toEncoding (WithAliases a x)
-- | HS.null a = toEncoding x
-- | otherwise = case toEncoding
aliases :: WithAliases a x -> HS.HashSet a
aliases (WithAliases h _) = h
instance (Binary a, Binary x) => Binary (WithAliases a x)
instance (Hashable a) => ToAliases (WithAliases a x) where
toAliases (WithAliases h _) = h
newtype Aliased a x = Aliased { unAliased :: Either a x }
deriving newtype (Bifoldable, Bifunctor, Bitraversable, Binary, Eq, Foldable, Functor, Generic, Generic1, Hashable, Ord, Traversable)
deriving stock (Show)
class (Eq a, Hashable a) => ToAliases x a where
toAliases :: x -> HS.HashSet a
instance Hashable a => ToAliases a a where
toAliases = HM.singleton
instance (Eq a, Hashable a) => ToAliases (HashSet a) a where
toAliases = id
instance ToAliases x a => ToAliases [x] a where
toAliases = foldMap toAliases
class FromAlias a x where
fromAlias :: MonadThrow m => a -> m x
instance FromAlias a a where
fromAlias = pure
instance (FromAlias a x, FromAlias b x) => FromAlias (Either a b) x where
fromAlias = either fromAlias fromAlias
instance FromAlias a x => FromAlias (Aliased a x) x where
fromAlias = fromAlias . unAliased
newtype AliasMap a x = AliasMap (HM.HashMap a x)
deriving newtype (Binary, Foldable, Functor, Generic, Generic1, Semigroup, Monoid, Traversable)
deriving stock (Show)
buildAliasMap :: (Foldable t, ToAliases x a) => t x -> AliasMap a x
buildAliasMap = fmap Aliasmap $ foldMap $ \x -> x <$ HS.toMap (toAliases x)
lookupAlias :: (MonadThrow m, Hashable a, Show a) => a -> AliasMap a x -> m x
lookupAlias a (AliasMap h) = maybe (throwM $ NoAlias a) pure $ HM.lookup a h
newtype NoAlias a = NoAlias a
deriving (Eq, Show)
instance Show a => Exception (NoAlias a) where
displayException (NoAlias a) = show a <> " is not an alias"
missingAlias :: MonadThrow m => a -> m b
missingAlias = throwM . NoAlias
|
