diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index ca23fd041..e30c061ee 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/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 diff --git a/src/Handler/Utils/Form/MassInput/Liveliness.hs b/src/Handler/Utils/Form/MassInput/Liveliness.hs new file mode 100644 index 000000000..53c33d236 --- /dev/null +++ b/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)) + +