{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveAnyClass #-} module Data.Container.Reusable where import Prelude hiding ((.)) import Control.Lens hiding (Indexable, Ixed) import Data.Container.Class import Data.Container.List import Data.Container.Opts (Opt(P,N), Query(..), ModsOf, ParamsOf, Unchecked, Inplace, Ixed) import Data.Container.Proxy import Data.Default import Data.Functor.Utils import Data.Layer import Data.List ((\\)) import Data.Monoid ---------------------- -- === Reusable === -- ---------------------- data Reusable idx a = Reusable [idx] !a deriving (Functor, Foldable, Traversable, Monoid) type Reusable' a = Reusable (Index a) a type instance Index (Reusable idx a) = Index (Container a) type instance Item (Reusable idx a) = Item (Container a) type instance Container (Reusable idx a) = Reusable idx a type instance DataStore (Reusable idx a) = Container a instance Monad m => IsContainerM m (Reusable idx a) where fromContainerM = return instance Monad m => HasContainerM m (Reusable idx a) where viewContainerM = return setContainerM = const . return type instance Unlayered (Reusable idx a) = a instance Layered (Reusable idx a) where layered = lens (\(Reusable _ a) -> a) (\(Reusable ixs _) a -> Reusable ixs a) instance Monad m => LayeredM m (Reusable idx a) instance (IsContainer a, FromList (Container a)) => FromList (Reusable idx a) where fromList = Reusable mempty . fromContainer . fromList instance Default a => Default (Reusable idx a) where def = Reusable def def _indexes :: Lens' (Reusable idx a) [idx] _indexes = lens (\(Reusable ixs _) -> ixs) (\(Reusable _ a) ixs -> Reusable ixs a) instance (ToList (Container a), HasContainer a) => ToList (Reusable idx a) where toList = toList . view container . unlayer instance ( Show (Item a), TracksElems (Item a) (Reusable idx a) ) => Show (Reusable idx a) where show a = "Reusable [" <> intercalate ", " (fmap show (elems_ a :: [Item a])) <> "]" ------------------------ -- === Instances === --- ------------------------ -- === Finite === -- [+] Measurable -- [+] MinBounded -- [+] MaxBounded type instance ParamsOf MeasurableOp (Reusable idx a) = ParamsOf MeasurableOp (Container a) type instance ModsOf MeasurableOp (Reusable idx a) = ModsOf MeasurableOp (Container a) type instance ParamsOf MinBoundedOp (Reusable idx a) = ParamsOf MinBoundedOp (Container a) type instance ModsOf MinBoundedOp (Reusable idx a) = ModsOf MinBoundedOp (Container a) type instance ParamsOf MaxBoundedOp (Reusable idx a) = ParamsOf MaxBoundedOp (Container a) type instance ModsOf MaxBoundedOp (Reusable idx a) = ModsOf MaxBoundedOp (Container a) instance (MeasurableQM (GetOpts ms) (GetOpts ps) m a) => MeasurableQM_ ms ps m (Reusable idx a) where sizeM_ _ = sizeQM (Query :: Query (GetOpts ms) (GetOpts ps)) . unlayer instance (MinBoundedQM (GetOpts ms) (GetOpts ps) m idx a, idx ~ idx') => MinBoundedQM_ ms ps m idx (Reusable idx' a) where minBoundM_ _ = minBoundQM (Query :: Query (GetOpts ms) (GetOpts ps)) . unlayer instance (MaxBoundedQM (GetOpts ms) (GetOpts ps) m idx a, idx ~ idx') => MaxBoundedQM_ ms ps m idx (Reusable idx' a) where maxBoundM_ _ = maxBoundQM (Query :: Query (GetOpts ms) (GetOpts ps)) . unlayer -- === Construction === -- [+] Singleton -- [+] Allocable -- [+] Expandable -- [+] Growable type instance ParamsOf SingletonOp (Reusable idx a) = ParamsOf SingletonOp (Container a) type instance ModsOf SingletonOp (Reusable idx a) = ModsOf SingletonOp (Container a) type instance ParamsOf AllocableOp (Reusable idx a) = ParamsOf AllocableOp (Container a) type instance ModsOf AllocableOp (Reusable idx a) = ModsOf AllocableOp (Container a) type instance ParamsOf ExpandableOp (Reusable idx a) = ParamsOf ExpandableOp (Container a) type instance ModsOf ExpandableOp (Reusable idx a) = ModsOf ExpandableOp (Container a) type instance ParamsOf GrowableOp (Reusable idx a) = ParamsOf GrowableOp (Container a) type instance ModsOf GrowableOp (Reusable idx a) = ModsOf GrowableOp (Container a) instance ( SingletonQM (Ixed ': GetOpts ms) (GetOpts ps) m el a, idx ~ Index (Container a)) => SingletonQM_ ms ps m el (Reusable idx a) where singletonM_ _ el = do Res (ix,ds) r <- singletonQM (Query :: Query (Ixed ': GetOpts ms) (GetOpts ps)) el return $ Res ds $ Reusable [ix] r instance ( AllocableQM (Ixed ': GetOpts ms) (GetOpts ps) m a, idx ~ Index (Container a)) => AllocableQM_ ms ps m (Reusable idx a) where allocM_ _ i = do Res (ixs,ds) r <- allocQM (Query :: Query (Ixed ': GetOpts ms) (GetOpts ps)) i return $ Res ds $ Reusable ixs r instance ( ExpandableQM (Ixed ': GetOpts ms) (GetOpts ps) m a, idx ~ Index (Container a)) => ExpandableQM_ ms ps m (Reusable idx a) where expandM_ _ (Reusable ixs a) = do Res (ixs',ds) r <- expandQM (Query :: Query (Ixed ': GetOpts ms) (GetOpts ps)) a return $ Res ds $ Reusable (ixs <> ixs') r instance ( GrowableQM (Ixed ': GetOpts ms) (GetOpts ps) m a, idx ~ Index (Container a)) => GrowableQM_ ms ps m (Reusable idx a) where growM_ _ i (Reusable ixs a) = do Res (ixs',ds) r <- growQM (Query :: Query (Ixed ': GetOpts ms) (GetOpts ps)) i a return $ Res ds $ Reusable (ixs <> ixs') r -- === Modification === -- [+] Appendable -- [+] Prependable -- [+] Addable -- [ ] Removable -- [+] Insertable -- [+] Freeable -- [+] Reservable type instance ParamsOf AppendableOp (Reusable idx a) = ParamsOf AppendableOp (Container a) type instance ModsOf AppendableOp (Reusable idx a) = ModsOf AppendableOp (Container a) type instance ParamsOf PrependableOp (Reusable idx a) = ParamsOf PrependableOp (Container a) type instance ModsOf PrependableOp (Reusable idx a) = ModsOf PrependableOp (Container a) type instance ParamsOf AddableOp (Reusable idx a) = ParamsOf AddableOp (Container a) type instance ModsOf AddableOp (Reusable idx a) = ModsOf AddableOp (Container a) type instance ParamsOf InsertableOp (Reusable idx a) = (Unchecked ': Inplace ': ParamsOf InsertableOp (Container a)) type instance ModsOf InsertableOp (Reusable idx a) = ModsOf InsertableOp (Container a) type instance ParamsOf FreeableOp (Reusable idx a) = ParamsOf FreeableOp (Container a) type instance ModsOf FreeableOp (Reusable idx a) = ModsOf FreeableOp (Container a) type instance ParamsOf ReservableOp (Reusable idx a) = '[] type instance ModsOf ReservableOp (Reusable idx a) = '[Ixed] instance (AppendableQM (GetOpts ms) (GetOpts ps) m el a) => AppendableQM_ ms ps m el (Reusable idx a) where appendM_ _ = nested layered . appendQM (Query :: Query (GetOpts ms) (GetOpts ps)) instance (PrependableQM (GetOpts ms) (GetOpts ps) m el a) => PrependableQM_ ms ps m el (Reusable idx a) where prependM_ _ = nested layered . prependQM (Query :: Query (GetOpts ms) (GetOpts ps)) instance (InsertableQM (GetOpts ms) (GetOpts ps) m idx el a , ExpandableM m (Reusable idx a) , Result_ InsertableOp (IdxElInfo idx el (Container a)) (GetOpts ms) ~ Result_ AddableOp (ElInfo el (Reusable idx a)) (GetOpts ms) ) => AddableQM_ ms ps m el (Reusable idx a) where addM_ q el t = case view _indexes t of (x:xs) -> fmap2 (Reusable xs) $ insertQM (Query :: Query (GetOpts ms) (GetOpts ps)) x el $ unlayer t [] -> addM_ q el =<< expandM t instance (InsertableQM (GetOpts ms) (GetOpts ps) m idx el a, idx ~ idx') => InsertableQM_ ms (P Unchecked ': P Inplace ': ps) m idx el (Reusable idx' a) where insertM_ _ = nested layered .: insertQM (Query :: Query (GetOpts ms) (GetOpts ps)) instance (FreeableQM (GetOpts ms) (GetOpts ps) m idx a, idx ~ idx') => FreeableQM_ ms ps m idx (Reusable idx' a) where freeM_ _ idx = fmap2 (_indexes %~ (idx:)) . nested layered (freeQM (Query :: Query (GetOpts ms) (GetOpts ps)) idx) instance (Monad m, idx ~ Index (Container a)) => ReservableQM_ '[P Ixed] ps m (Reusable idx a) where reserveM_ _ (Reusable (i:is) a) = return $ Res (i,()) (Reusable is a) ---- === Indexing === -- [+] Indexable -- [+] TracksFreeIxes -- [+] TracksUsedIxes -- [+] TracksIxes -- [+] TracksElems type instance ParamsOf IndexableOp (Reusable idx a) = ParamsOf IndexableOp (Container a) type instance ModsOf IndexableOp (Reusable idx a) = ModsOf IndexableOp (Container a) type instance ParamsOf TracksIxesOp (Reusable idx a) = ParamsOf TracksIxesOp (Container a) type instance ModsOf TracksIxesOp (Reusable idx a) = ModsOf TracksIxesOp (Container a) type instance ParamsOf TracksFreeIxesOp (Reusable idx a) = '[] type instance ModsOf TracksFreeIxesOp (Reusable idx a) = '[] type instance ParamsOf TracksUsedIxesOp (Reusable idx a) = '[] type instance ModsOf TracksUsedIxesOp (Reusable idx a) = '[] type instance ParamsOf TracksElemsOp (Reusable idx a) = '[] type instance ModsOf TracksElemsOp (Reusable idx a) = '[] instance (IndexableQM (GetOpts ms) (GetOpts ps) m idx el a, idx ~ idx') => IndexableQM_ ms ps m idx el (Reusable idx' a) where indexM_ _ idx = indexQM (Query :: Query (GetOpts ms) (GetOpts ps)) idx . unlayer instance (TracksIxesQM (GetOpts ms) (GetOpts ps) m idx a, idx ~ idx') => TracksIxesQM_ ms ps m idx (Reusable idx' a) where ixesM_ _ = ixesQM (Query :: Query (GetOpts ms) (GetOpts ps)) . unlayer instance (Monad m, idx ~ idx') => TracksFreeIxesQM_ '[] ps m idx (Reusable idx' a) where freeIxesM_ _ = return . Res () . view _indexes instance (TracksIxes idx (Reusable idx a) , TracksFreeIxes idx (Reusable idx a), idx ~ idx', Monad m, Eq idx) => TracksUsedIxesQM_ '[] ps m idx (Reusable idx' a) where usedIxesM_ _ t = return $ Res () $ ixes t \\ freeIxes t instance ( TracksUsedIxes idx (Reusable idx a) , Indexable idx el (Reusable idx a) , Monad m ) => TracksElemsQM_ '[] ps m el (Reusable idx a) where elemsM_ _ t = return $ Res () $ fmap (flip index_ t) (usedIxes_ t :: [idx]) where