Minor refactor

src/Handler/Utils/Form/MassInput.hs

@@ -4,18 +4,18 @@ module Handler.Utils.Form.MassInput
   ( MassInput(..)
   , defaultMiLayout
   , massInput
-  , BoxDimension(..)
-  , IsBoxCoord(..), boxDimension
-  , Liveliness(..)
+  , module Handler.Utils.Form.MassInput.Liveliness
   , massInputA
   , massInputList
   , ListLength(..), ListPosition(..), miDeleteList
+  , EnumLiveliness(..), EnumPosition(..)
   ) where
 
 import Import
 import Utils.Form
 import Utils.Lens
 import Handler.Utils.Form (secretJsonField)
+import Handler.Utils.Form.MassInput.Liveliness
 
 import Data.Aeson
 
@@ -26,37 +26,15 @@ import Text.Blaze (Markup)
 import qualified Data.Text as Text
 
 import qualified Data.Set as Set
+import qualified Data.IntSet as IntSet
 import Data.Map ((!))
 import qualified Data.Map as Map
 import qualified Data.Foldable as Fold
-import Data.List (genericLength, genericIndex, iterate)
+import Data.List (iterate)
 
 import Control.Monad.Reader.Class (MonadReader(local))
 
 
-data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n)
-
-class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where
-  boxDimensions :: [BoxDimension x]
-  boxOrigin :: x
-
-boxDimension :: IsBoxCoord x => Natural -> BoxDimension x
-boxDimension n
-  | n < genericLength dims = genericIndex dims n
-  | otherwise = error "boxDimension: insufficient dimensions"
-  where
-    dims = boxDimensions
-
--- zeroDimension :: IsBoxCoord x => Natural -> x -> x
--- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
-
-class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
-  type BoxCoord a :: *
-  liveCoords :: Prism' (Set (BoxCoord a)) a
-  liveCoord :: BoxCoord a -> Prism' Bool a
-  liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))
-
-
 newtype ListLength = ListLength { unListLength :: Natural }
   deriving newtype (Num, Integral, Real, Enum, PathPiece)
   deriving (Eq, Ord, Generic, Typeable, Read, Show)
@@ -78,7 +56,7 @@ newtype ListPosition = ListPosition { unListPosition :: Natural }
 makeWrapped ''ListPosition
 
 instance IsBoxCoord ListPosition where
-  boxDimensions = [BoxDimension id]
+  boxDimensions = [BoxDimension _Wrapped]
   boxOrigin = 0
 
 instance Liveliness ListLength where
@@ -96,7 +74,42 @@ instance Liveliness ListLength where
         = Nothing
         where
           max' = Set.lookupMax ns
-  liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just 0) (1 <$ guard (n == 0)))
+  liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just bottom) (1 <$ guard (n == 0)))
+
+
+newtype EnumLiveliness enum = EnumLiveliness { unEnumLiveliness :: IntSet }
+  deriving (Eq, Ord, Generic, Typeable, Read, Show)
+
+makeWrapped ''EnumLiveliness
+
+instance JoinSemiLattice (EnumLiveliness enum) where
+  (EnumLiveliness a) \/ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.union` b
+instance MeetSemiLattice (EnumLiveliness enum) where
+  (EnumLiveliness a) /\ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.intersection` b
+instance Lattice (EnumLiveliness enum)
+instance BoundedJoinSemiLattice (EnumLiveliness enum) where
+  bottom = EnumLiveliness IntSet.empty
+instance (Enum enum, Bounded enum) => BoundedMeetSemiLattice (EnumLiveliness enum) where
+  top = EnumLiveliness . IntSet.fromList $ map (fromEnum :: enum -> Int) [minBound..maxBound]
+instance (Enum enum, Bounded enum) => BoundedLattice (EnumLiveliness enum)
+
+
+newtype EnumPosition enum = EnumPosition { unEnumPosition :: enum }
+  deriving newtype (Enum, Bounded, PathPiece, ToJSONKey, FromJSONKey)
+  deriving (Eq, Ord, Generic, Typeable, Read, Show)
+
+makeWrapped ''EnumPosition
+
+instance (Enum enum, Bounded enum, PathPiece enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => IsBoxCoord (EnumPosition enum) where
+  boxDimensions = [BoxDimension _Wrapped]
+  boxOrigin = minBound
+
+instance (Enum enum, Bounded enum, PathPiece enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => Liveliness (EnumLiveliness enum) where
+  type BoxCoord (EnumLiveliness enum) = EnumPosition enum
+  liveCoords = iso fromSet toSet
+    where
+      toSet = Set.fromList . map toEnum . IntSet.toList . unEnumLiveliness
+      fromSet = EnumLiveliness . IntSet.fromList . map fromEnum . Set.toList
 
 
 miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition)
@@ -270,7 +283,10 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
               [] -> return dimRes'
               ((_, BoxDimension dim) : _) -> do
                 let
-                  miCoords = Set.fromList . takeWhile (\c -> review (liveCoord c) sentLiveliness) $ iterate (over dim succ) miCoord
+                  miCoords
+                    = Set.fromList
+                    . takeWhile (\c -> review (liveCoord c) sentLiveliness)
+                    $ set dim <$> enumFrom (miCoord ^. dim) <*> pure miCoord
                 dimRess <- sequence $ Map.fromSet (\c -> addForm' c remDims) miCoords
                 return $ dimRes' `Map.union` fold dimRess
 

src/Handler/Utils/Form/MassInput/Liveliness.hs

@@ -0,0 +1,45 @@
+module Handler.Utils.Form.MassInput.Liveliness
+  ( BoxDimension(..)
+  , IsBoxCoord(..)
+  , boxDimension
+  , Liveliness(..)
+  ) where
+
+import ClassyPrelude
+
+import Web.PathPieces(PathPiece)
+import Data.Aeson (ToJSONKey, FromJSONKey)
+
+import Numeric.Natural
+
+import Utils.Lens
+
+import Algebra.Lattice
+
+import qualified Data.Set as Set
+import Data.List (genericLength, genericIndex)
+
+
+data BoxDimension x = forall n. Enum n => BoxDimension (Lens' x n)
+
+class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where
+  boxDimensions :: [BoxDimension x]
+  boxOrigin :: x
+
+boxDimension :: IsBoxCoord x => Natural -> BoxDimension x
+boxDimension n
+  | n < genericLength dims = genericIndex dims n
+  | otherwise = error "boxDimension: insufficient dimensions"
+  where
+    dims = boxDimensions
+
+-- zeroDimension :: IsBoxCoord x => Natural -> x -> x
+-- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
+
+class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
+  type BoxCoord a :: *
+  liveCoords :: Prism' (Set (BoxCoord a)) a
+  liveCoord :: BoxCoord a -> Prism' Bool a
+  liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))
+
+