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
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Data.Levels
( Levels
, allLevels
, numLevels
, nextLevel
, prevLevel
, mkLevels1
, mkLevels
, oneLevel
, current
, ComonadStore(..)
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding ((<.>), Empty, foldMap)
import Xanthous.Util (between, EqProp, EqEqProp(..))
import Xanthous.Util.Comonad (current)
import Xanthous.Orphans ()
--------------------------------------------------------------------------------
import Control.Comonad.Store
import Control.Comonad.Store.Zipper
import Data.Aeson (ToJSON(..), FromJSON(..))
import Data.Aeson.Generic.DerivingVia
import Data.Functor.Apply
import Data.Foldable (foldMap)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromJust)
import Data.Sequence (Seq((:<|), Empty))
import Data.Semigroup.Foldable.Class
import Data.Text (replace)
import Test.QuickCheck
--------------------------------------------------------------------------------
-- | Collection of levels plus a pointer to the current level
--
-- Navigation is via the 'Comonad' instance. We can get the current level with
-- 'extract':
--
-- extract @Levels :: Levels level -> level
--
-- For access to and modification of the level, use
-- 'Xanthous.Util.Comonad.current'
newtype Levels a = Levels { levelZipper :: Zipper Seq a }
deriving stock (Generic)
deriving (Functor, Comonad, Foldable) via (Zipper Seq)
type instance Element (Levels a) = a
instance MonoFoldable (Levels a)
instance MonoFunctor (Levels a)
instance MonoTraversable (Levels a)
instance ComonadStore Word Levels where
pos = toEnum . pos . levelZipper
peek i = peek (fromEnum i) . levelZipper
instance Traversable Levels where
traverse f (Levels z) = Levels <$> traverse f z
instance Foldable1 Levels
instance Traversable1 Levels where
traverse1 f levs@(Levels z) = seek (pos levs) . partialMkLevels <$> go (unzipper z)
where
go Empty = error "empty seq, unreachable"
go (x :<| xs) = (<|) <$> f x <.> go xs
-- | Always takes the position of the latter element
instance Semigroup (Levels a) where
levs₁ <> levs₂
= seek (pos levs₂)
. partialMkLevels
$ allLevels levs₁ <> allLevels levs₂
-- | The number of levels stored in 'Levels'
--
-- Equivalent to 'Data.Foldable.length', but likely faster
numLevels :: Levels a -> Word
numLevels = toEnum . size . levelZipper
-- | Make Levels from a Seq. Throws an error if the seq is not empty
partialMkLevels :: Seq a -> Levels a
partialMkLevels = Levels . fromJust . zipper
-- | Make Levels from a possibly-empty structure
mkLevels :: Foldable1 f => f level -> Maybe (Levels level)
mkLevels = fmap Levels . zipper . foldMap pure
-- | Make Levels from a non-empty structure
mkLevels1 :: Foldable1 f => f level -> Levels level
mkLevels1 = fromJust . mkLevels
oneLevel :: a -> Levels a
oneLevel = mkLevels1 . Identity
-- | Get a sequence of all the levels
allLevels :: Levels a -> Seq a
allLevels = unzipper . levelZipper
-- | Step to the next level, generating a new level if necessary using the given
-- applicative action
nextLevel
:: Applicative m
=> m level -- ^ Generate a new level, if necessary
-> Levels level
-> m (Levels level)
nextLevel genLevel levs
| succ (pos levs) < numLevels levs
= pure $ seeks succ levs
| otherwise
= genLevel <&> \level ->
seek (pos levs + 1) . partialMkLevels $ allLevels levs |> level
-- | Go to the previous level. Returns Nothing if 'pos' is 0
prevLevel :: Levels level -> Maybe (Levels level)
prevLevel levs | pos levs == 0 = Nothing
| otherwise = Just $ seeks pred levs
--------------------------------------------------------------------------------
-- | alternate, slower representation of Levels we can Iso into to perform
-- various operations
data AltLevels a = AltLevels
{ _levels :: NonEmpty a
, _currentLevel :: Word -- ^ invariant: is within the bounds of _levels
}
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
(AltLevels a)
makeLenses ''AltLevels
alt :: Iso (Levels a) (Levels b) (AltLevels a) (AltLevels b)
alt = iso hither yon
where
hither levs = AltLevels (NE.fromList . toList $ allLevels levs) (pos levs)
yon (AltLevels levs curr) = seek curr $ mkLevels1 levs
instance Eq a => Eq (Levels a) where
(==) = (==) `on` view alt
deriving via EqEqProp (Levels a) instance Eq a => EqProp (Levels a)
instance Show a => Show (Levels a) where
show = unpack . replace "AltLevels" "Levels" . pack . show . view alt
instance NFData a => NFData (Levels a) where
rnf = rnf . view alt
instance ToJSON a => ToJSON (Levels a) where
toJSON = toJSON . view alt
instance FromJSON a => FromJSON (Levels a) where
parseJSON = fmap (review alt) . parseJSON
instance Arbitrary a => Arbitrary (AltLevels a) where
arbitrary = do
_levels <- arbitrary
_currentLevel <- choose (0, pred . toEnum . length $ _levels)
pure AltLevels {..}
shrink als = do
_levels <- shrink $ als ^. levels
_currentLevel <- filter (between 0 $ pred . toEnum . length $ _levels)
$ shrink $ als ^. currentLevel
pure AltLevels {..}
instance Arbitrary a => Arbitrary (Levels a) where
arbitrary = review alt <$> arbitrary
shrink = fmap (review alt) . shrink . view alt
instance CoArbitrary a => CoArbitrary (Levels a) where
coarbitrary = coarbitrary . view alt
instance Function a => Function (Levels a) where
function = functionMap (view alt) (review alt)
|
