about summary refs log tree commit diff
path: root/users/grfn/xanthous/src/Xanthous/Data/Levels.hs
blob: efc0f53acecf17d81c9351cbe51754a5b3cfe641 (plain) (blame)
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
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Data.Levels
  ( Levels
  , allLevels
  , 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)
    deriving (ComonadStore Int) via (Zipper Seq)

type instance Element (Levels a) = a
instance MonoFoldable (Levels a)
instance MonoFunctor (Levels a)
instance MonoTraversable (Levels a)

instance Traversable Levels where
  traverse f (Levels z) = Levels <$> traverse f z

instance Foldable1 Levels

instance Traversable1 Levels where
  traverse1 f (Levels z) = seek (pos z) . 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₂

-- | 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
  | pos levs + 1 < size (levelZipper 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 :: Int -- ^ 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, length _levels - 1)
    pure AltLevels {..}
  shrink als = do
    _levels <- shrink $ als ^. levels
    _currentLevel <- filter (between 0 $ length _levels - 1)
                    $ 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)