diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/container.cabal b/container.cabal --- a/container.cabal +++ b/container.cabal @@ -1,40 +1,79 @@ --- This file has been generated from package.yaml by hpack version 0.20.0. --- --- see: https://github.com/sol/hpack --- --- hash: 33bcc177224f7b11ee2bedc766f0da717dbbed2bf70e49e7b81beb1bcd4f755a +name: container +version: 1.0 +synopsis: Containers abstraction and utilities. +-- description: +license: Apache-2.0 +license-file: LICENSE +author: Wojciech Danilo +maintainer: Wojciech Danilo +stability: experimental +homepage: https://github.com/wdanilo/containers +bug-reports: https://github.com/wdanilo/containers/issues +copyright: Copyright (C) 2015 Wojciech Danilo +category: Text +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 -name: container -version: 0.3.4 -synopsis: Containers abstraction and utilities. -category: Data -stability: experimental -homepage: https://github.com/luna/container -bug-reports: https://github.com/luna/container/issues -author: Luna Team -maintainer: Wojciech Danilo -copyright: Copyright (C) 2018 Luna Team -license: Apache-2.0 -license-file: LICENSE -build-type: Simple -cabal-version: >= 1.10 -library - hs-source-dirs: - src - default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse DuplicateRecordFields EmptyDataDecls FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving InstanceSigs LambdaCase MonadComprehensions MultiWayIf NamedWildCards NegativeLiterals NoImplicitPrelude NumDecimals OverloadedLabels PackageImports QuasiQuotes PatternSynonyms RankNTypes RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UnicodeSyntax ViewPatterns LiberalTypeSynonyms RelaxedPolyRec - ghc-options: -Wall -O2 - build-depends: - base >=4.10 && <4.12 - , containers - , convert - , lens - , text - exposed-modules: - Data.Item - Data.List.Class - Data.Sequence.Class - Data.Set.Mutable.Class - other-modules: - Paths_container - default-language: Haskell2010 +Library + hs-source-dirs: src + ghc-options: -Wall -O2 + default-language: Haskell2010 + + default-extensions: ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DoAndIfThenElse + EmptyDataDecls + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + MultiParamTypeClasses + OverloadedStrings + StandaloneDeriving + TemplateHaskell + TupleSections + TypeOperators + ViewPatterns + TypeFamilies + + exposed-modules: Data.Container + Data.Container.Auto + Data.Container.Class + Data.Container.Hetero + Data.Container.Immersed + Data.Container.Instances + Data.Container.Instances.IntSet + Data.Container.Instances.Vector.Lazy + Data.Container.List + Data.Container.Opts + Data.Container.Parametrized + Data.Container.Poly + Data.Container.Proxy + Data.Container.Resizable + Data.Container.Reusable + Data.Container.Type + Data.Container.Weak + + build-depends: base >=4.6 && <4.9 + , containers + , data-default + , data-layer + , functor-utils + , lens + , lens-utils + , mtl + , template-haskell + , transformers + , transformers-base + , typelevel + , vector + , text diff --git a/src/Data/Container.hs b/src/Data/Container.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container.hs @@ -0,0 +1,8 @@ +module Data.Container ( + module Data.Container, + module X +) where + +import Data.Container.Class as X +import Data.Container.Opts as X (ixed, raw, try, unchecked, unsafe, inplace) +import Data.Container.Instances () diff --git a/src/Data/Container/Auto.hs b/src/Data/Container/Auto.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container/Auto.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Container.Auto where + +import Prelude + +import Control.Lens +import Control.Lens.Utils +import Data.Container.Class +import Data.Container.Resizable +import Data.Container.Reusable +import Data.Container.List +import Data.Layer +import Data.Default + + +#define AUTO (Reusable idx (Resizable style a)) + +newtype Auto idx style a = Auto AUTO deriving (Functor, Traversable, Foldable, Monoid, Default) +type Auto' style a = Auto (Index (Container a)) style a + +deriving instance (IsContainer a, FromList (Container a), Default style) => FromList (Auto idx style a) + +type instance Index (Auto idx style a) = Index AUTO +type instance Item (Auto idx style a) = Item AUTO + +type instance DataStore (Auto idx style a) = DataStore AUTO +type instance Container (Auto idx style a) = Container AUTO +instance Monad m => IsContainerM m (Auto idx style a) where fromContainerM = fmap Auto . fromContainerM +instance Monad m => HasContainerM m (Auto idx style a) where viewContainerM = viewContainerM . view layered + setContainerM = layered . setContainerM + +instance (HasContainer a, ToList (Container a)) => ToList (Auto idx s a) where toList = toList . unwrap' + +-- Wrappers & layers + +type instance Unlayered (Auto idx style a) = AUTO +instance Layered (Auto idx style a) +instance Monad m => LayeredM m (Auto idx style a) +instance Wrapped (Auto idx style a) where + type Unwrapped (Auto idx style a) = AUTO + _Wrapped' = iso (\(Auto a) -> a) Auto + + +deriving instance Show AUTO => Show (Auto idx style a) + +--instance Show a => Show (Auto idx style a) where +-- showsPrec d (Auto a) = showParen (d > app_prec) $ +-- showString "Auto " . showsPrec (succ app_prec) (view (layered . layered) a) +-- --showString $ "Auto " <> show (elems a :: [Item a]) -- . showsPrec (succ app_prec) (view (layered . layered) a) +-- where app_prec = 10 + diff --git a/src/Data/Container/Class.hs b/src/Data/Container/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container/Class.hs @@ -0,0 +1,482 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FunctionalDependencies #-} + + +module Data.Container.Class (module Data.Container.Class, module X) where + +--import Prologue hiding (Indexable, index, Bounded, Ixed, Simple, Indexed) +import Prelude hiding ((.)) + +import Control.Lens as X (Index) + +import qualified Data.Container.Opts as Opts +import Data.Container.Opts (Query(..), Opt(..), Knowledge(..), queryBuilder, withTransFunc) +import Data.Container.Poly (Simple) +import GHC.Exts (Constraint) +import Data.Functor.Utils +import Control.Monad.Identity +import Control.Lens hiding (Indexable, index, Bounded, Ixed, Simple, Indexed) +import Data.List (intersperse) + + +data Impossible = Impossible deriving (Show) +data ImpossibleM a = ImpossibleM deriving (Show, Functor) +type ImpTL = '[Impossible] + + + +impossible = error "Impossible happened." + +---------------------------- +-- === General utilities === +---------------------------- + +type family Container a +type family Item a + +-- | Points to the real structure handling the data. Used mainly internally. +type family DataStore a + +type HasContainer = HasContainerM Identity +class HasContainerM m a where + viewContainerM :: a -> m (Container a) + setContainerM :: Container a -> a -> m a + default viewContainerM :: (Container a ~ Container (Unwrapped a), Wrapped a, HasContainerM m (Unwrapped a)) => a -> m (Container a) + viewContainerM = viewContainerM . view _Wrapped' + default setContainerM :: (Container a ~ Container (Unwrapped a), Wrapped a, HasContainerM m (Unwrapped a), Functor m) => Container a -> a -> m a + setContainerM = _Wrapped' . setContainerM + +type IsContainer = IsContainerM Identity +class HasContainerM m a => IsContainerM m a where + fromContainerM :: Container a -> m a + --default fromContainerM :: (Monad m) => Container a -> m a + --fromContainerM = view unwrapped' . fromContainerM + + +container :: HasContainer a => Lens' a (Container a) +container = lens (runIdentity . viewContainerM) (runIdentity .: flip setContainerM) + +fromContainer :: IsContainer a => Container a -> a +fromContainer = runIdentity . fromContainerM + +withContainerM :: (Monad m, HasContainerM m a) => (Container a -> m (Container a)) -> a -> m a +withContainerM f l = viewContainerM l >>= f >>= flip setContainerM l + +withContainerM' :: (Monad m, HasContainerM m a) => (Container a -> Container a) -> a -> m a +withContainerM' = withContainerM . (return .) + +-- Type level utilities + +type family PrimStoreOf a where PrimStoreOf a = PrimStoreOf' (DataStore a) a +type family PrimStoreOf' t a where PrimStoreOf' a a = a + PrimStoreOf' t a = PrimStoreOf' (DataStore (Container (DataStore a))) (Container (DataStore a)) + + +---------------------------- +-- === Results & Infos === +---------------------------- + +-- === Info === + +data Info idx el cont = Info idx el cont + +type PrimInfo = 'Info 'Unknown 'Unknown +type ElInfo el = 'Info 'Unknown ('Known el) +type IdxInfo idx = 'Info ('Known idx) 'Unknown +type IdxElInfo idx el = 'Info ('Known idx) ('Known el) + + + +-- === Results === + +data Res datas a = Res datas a deriving (Show, Functor, Traversable, Foldable) + +type Result op info mods = Res (Result_ op info mods) + +type PrimResult op ms a = Result op (PrimInfo a) ms +type ElResult op ms el a = Result op (ElInfo el a) ms +type IdxResult op ms idx a = Result op (IdxInfo idx a) ms +type IdxElResult op ms idx el a = Result op (IdxElInfo idx el a) ms + +type family Result_ op info (mods :: [*]) where + Result_ op info '[] = () + Result_ op info (m ': ms) = (ModResult op info m, Result_ op info ms) + + + +-- === Opts === + +type family IdxMod op ix + +type family ModResult op (info :: Info (Knowledge *) (Knowledge *) *) mod + +type family GetOpts (m :: [Opt *]) :: [*] where + GetOpts '[] = '[] + GetOpts (P a ': ms) = a ': GetOpts ms + GetOpts (N ': ms) = GetOpts ms + + + +-- === >>> Mods === + +type instance ModResult op ('Info (Known idx) el cont) Opts.Ixed = IdxMod op idx +type instance ModResult op ('Info Unknown el cont) Opts.Ixed = IdxMod op (Index cont) + + +----------------------------- +-- === Operations classes === +----------------------------- + +-- === Finite === + +-- Measurable +-- MinBounded +-- MaxBounded + +class Ctx ms m cont => MeasurableQM ms ps m cont where sizeQM :: Query ms ps -> cont -> m (PrimResult MeasurableOp ms (Container cont) Int) +class Ctx ms m cont => MinBoundedQM ms ps m idx cont where minBoundQM :: Query ms ps -> cont -> m (IdxResult MinBoundedOp ms idx (Container cont) idx) +class Ctx ms m cont => MaxBoundedQM ms ps m idx cont where maxBoundQM :: Query ms ps -> cont -> m (IdxResult MaxBoundedOp ms idx (Container cont) idx) + +data MeasurableOp = MeasurableOp +type MeasurableM = Simple MeasurableQM +type MeasurableQ ms ps = MeasurableQM ms ps Identity +type Measurable = Simple MeasurableQM Identity + +data MinBoundedOp = MinBoundedOp +type MinBoundedM = Simple MinBoundedQM +type MinBoundedQ ms ps = MinBoundedQM ms ps Identity +type MinBounded = Simple MinBoundedQM Identity + +data MaxBoundedOp = MaxBoundedOp +type MaxBoundedM = Simple MaxBoundedQM +type MaxBoundedQ ms ps = MaxBoundedQM ms ps Identity +type MaxBounded = Simple MaxBoundedQM Identity + +type BoundedQM ms ps m idx cont = (MinBoundedQM ms ps m idx cont, MaxBoundedQM ms ps m idx cont) +type BoundedM m idx cont = Simple MaxBoundedQM m idx cont +type BoundedQ ms ps m idx cont = MaxBoundedQM ms ps Identity idx cont +type Bounded idx cont = BoundedM Identity idx cont + +-- utils + +sizeM' = queryBuilder sizeQM +size' = withTransFunc (fmap2 runIdentity) sizeM' +sizeM = queryBuilder $ fmap formatResult .: sizeQM +size = withTransFunc (fmap2 runIdentity) sizeM + +minBoundM' = queryBuilder minBoundQM +minBound' = withTransFunc (fmap2 runIdentity) minBoundM' +minBoundM = queryBuilder $ fmap formatResult .: minBoundQM +minBound = withTransFunc (fmap2 runIdentity) minBoundM + +maxBoundM' = queryBuilder maxBoundQM +maxBound' = withTransFunc (fmap2 runIdentity) maxBoundM' +maxBoundM = queryBuilder $ fmap formatResult .: maxBoundQM +maxBound = withTransFunc (fmap2 runIdentity) maxBoundM + + + + +-- === Construction === + +-- Singleton +-- Allocable +-- Expandable +-- Growable + +class Ctx ms m cont => SingletonQM ms ps m el cont where singletonQM :: Query ms ps -> el -> m (ElResult SingletonOp ms el (Container cont) cont) +class Ctx ms m cont => ExpandableQM ms ps m cont where expandQM :: Query ms ps -> cont -> m (PrimResult ExpandableOp ms (Container cont) cont) +class Ctx ms m cont => AllocableQM ms ps m cont where allocQM :: Query ms ps -> Int -> m (PrimResult AllocableOp ms (Container cont) cont) +class Ctx ms m cont => GrowableQM ms ps m cont where growQM :: Query ms ps -> Int -> cont -> m (PrimResult GrowableOp ms (Container cont) cont) + +data SingletonOp = SingletonOp +type SingletonM = Simple SingletonQM +type SingletonQ ms ps = SingletonQM ms ps Identity +type Singleton = Simple SingletonQM Identity + +data AllocableOp = AllocableOp +type AllocableM = Simple AllocableQM +type AllocableQ ms ps = AllocableQM ms ps Identity +type Allocable = Simple AllocableQM Identity + +data ExpandableOp = ExpandableOp +type ExpandableM = Simple ExpandableQM +type ExpandableQ ms ps = ExpandableQM ms ps Identity +type Expandable = Simple ExpandableQM Identity + +data GrowableOp = GrowableOp +type GrowableM = Simple GrowableQM +type GrowableQ ms ps = GrowableQM ms ps Identity +type Growable = Simple GrowableQM Identity + +type instance IdxMod SingletonOp a = a +type instance IdxMod AllocableOp a = [a] +type instance IdxMod ExpandableOp a = [a] +type instance IdxMod GrowableOp a = [a] + +-- utils + +singletonM' = queryBuilder singletonQM +singleton' = withTransFunc (fmap2 runIdentity) singletonM' +singletonM = queryBuilder $ fmap formatResult .: singletonQM +singleton = withTransFunc (fmap2 runIdentity) singletonM + +allocM' = queryBuilder allocQM +alloc' = withTransFunc (fmap2 runIdentity) allocM' +allocM = queryBuilder $ fmap formatResult .: allocQM +alloc = withTransFunc (fmap2 runIdentity) allocM + +expandM' = queryBuilder expandQM +expand' = withTransFunc (fmap2 runIdentity) expandM' +expandM = queryBuilder $ fmap formatResult .: expandQM +expand = withTransFunc (fmap2 runIdentity) expandM + +growM' = queryBuilder growQM +grow' = withTransFunc (fmap3 runIdentity) growM' +growM = queryBuilder $ fmap formatResult .:. growQM +grow = withTransFunc (fmap3 runIdentity) growM + + + +-- === Modification === +-- Appendable +-- Prependable +-- Addable +-- Removable +-- Insertable +-- Freeable + + + +class Ctx ms m cont => AppendableQM ms ps m el cont where appendQM :: Query ms ps -> el -> cont -> m (ElResult AppendableOp ms el (Container cont) cont) +class Ctx ms m cont => PrependableQM ms ps m el cont where prependQM :: Query ms ps -> el -> cont -> m (ElResult PrependableOp ms el (Container cont) cont) +class Ctx ms m cont => AddableQM ms ps m el cont where addQM :: Query ms ps -> el -> cont -> m (ElResult AddableOp ms el (Container cont) cont) +class Ctx ms m cont => RemovableQM ms ps m el cont where removeQM :: Query ms ps -> el -> cont -> m (ElResult RemovableOp ms el (Container cont) cont) +class Ctx ms m cont => InsertableQM ms ps m idx el cont where insertQM :: Query ms ps -> idx -> el -> cont -> m (IdxElResult InsertableOp ms idx el (Container cont) cont) +class Ctx ms m cont => FreeableQM ms ps m idx cont where freeQM :: Query ms ps -> idx -> cont -> m (IdxResult FreeableOp ms idx (Container cont) cont) +class Ctx ms m cont => ReservableQM ms ps m cont where reserveQM :: Query ms ps -> cont -> m (PrimResult ReservableOp ms (Container cont) cont) + +data AppendableOp = AppendableOp +type AppendableM = Simple AppendableQM +type AppendableQ ms ps = AppendableQM ms ps Identity +type Appendable = Simple AppendableQM Identity + +data PrependableOp = PrependableOp +type PrependableM = Simple PrependableQM +type PrependableQ ms ps = PrependableQM ms ps Identity +type Prependable = Simple PrependableQM Identity + +data AddableOp = AddableOp +type AddableM = Simple AddableQM +type AddableQ ms ps = AddableQM ms ps Identity +type Addable = Simple AddableQM Identity + +data RemovableOp = RemovableOp +type RemovableM = Simple RemovableQM +type RemovableQ ms ps = RemovableQM ms ps Identity +type Removable = Simple RemovableQM Identity + +data InsertableOp = InsertableOp +type InsertableM = Simple InsertableQM +type InsertableQ ms ps = InsertableQM ms ps Identity +type Insertable = Simple InsertableQM Identity + +data FreeableOp = FreeableOp +type FreeableM = Simple FreeableQM +type FreeableQ ms ps = FreeableQM ms ps Identity +type Freeable = Simple FreeableQM Identity + +data ReservableOp = ReservableOp +type ReservableM = Simple ReservableQM +type ReservableQ ms ps = ReservableQM ms ps Identity +type Reservable = Simple ReservableQM Identity + +type instance IdxMod AppendableOp a = a +type instance IdxMod PrependableOp a = a +type instance IdxMod AddableOp a = a +type instance IdxMod RemovableOp a = a +type instance IdxMod InsertableOp a = a +type instance IdxMod ReservableOp a = a + +appendM' = queryBuilder appendQM +append' = withTransFunc (fmap3 runIdentity) appendM' +appendM = queryBuilder $ fmap formatResult .:. appendQM +append = withTransFunc (fmap3 runIdentity) appendM + +prependM' = queryBuilder prependQM +prepend' = withTransFunc (fmap3 runIdentity) prependM' +prependM = queryBuilder $ fmap formatResult .:. prependQM +prepend = withTransFunc (fmap3 runIdentity) prependM + +addM' = queryBuilder addQM +add' = withTransFunc (fmap3 runIdentity) addM' +addM = queryBuilder $ fmap formatResult .:. addQM +add = withTransFunc (fmap3 runIdentity) addM +add_ = withTransFunc (fmap3 res_) add' + +removeM' = queryBuilder removeQM +remove' = withTransFunc (fmap3 runIdentity) removeM' +removeM = queryBuilder $ fmap formatResult .:. removeQM +remove = withTransFunc (fmap3 runIdentity) removeM + +insertM' = queryBuilder insertQM +insert' = withTransFunc (fmap4 runIdentity) insertM' +insertM = queryBuilder $ fmap formatResult .:: insertQM +insert = withTransFunc (fmap4 runIdentity) insertM +insert_ = withTransFunc (fmap4 res_) insert' + +freeM' = queryBuilder freeQM +free' = withTransFunc (fmap3 runIdentity) freeM' +freeM = queryBuilder $ fmap formatResult .:. freeQM +free = withTransFunc (fmap3 runIdentity) freeM +free_ = withTransFunc (fmap3 res_) free' + +reserveM' = queryBuilder reserveQM +reserve' = withTransFunc (fmap2 runIdentity) reserveM' +reserveM = queryBuilder $ fmap formatResult .: reserveQM +reserve = withTransFunc (fmap2 runIdentity) reserveM + + + +---- === Indexing === + +-- Indexable +-- TracksFreeIxes +-- TracksUsedIxes +-- TracksIxes +-- TracksElems + +class Ctx ms m cont => IndexableQM ms ps m idx el cont where indexQM :: Query ms ps -> idx -> cont -> m (IdxElResult IndexableOp ms idx el (Container cont) el ) +class Ctx ms m cont => TracksFreeIxesQM ms ps m idx cont where freeIxesQM :: Query ms ps -> cont -> m (IdxResult TracksFreeIxesOp ms idx (Container cont) [idx]) +class Ctx ms m cont => TracksUsedIxesQM ms ps m idx cont where usedIxesQM :: Query ms ps -> cont -> m (IdxResult TracksUsedIxesOp ms idx (Container cont) [idx]) +class Ctx ms m cont => TracksIxesQM ms ps m idx cont where ixesQM :: Query ms ps -> cont -> m (IdxResult TracksIxesOp ms idx (Container cont) [idx]) +class Ctx2 m => TracksElemsQM ms ps m el cont where elemsQM :: Query ms ps -> cont -> m (ElResult TracksElemsOp ms el (Container cont) [el] ) + +data IndexableOp = IndexableOp +type IndexableM = Simple IndexableQM +type IndexableQ ms ps = IndexableQM ms ps Identity +type Indexable = Simple IndexableQM Identity + +data TracksFreeIxesOp = TracksFreeIxesOp +type TracksFreeIxesM = Simple TracksFreeIxesQM +type TracksFreeIxesQ ms ps = TracksFreeIxesQM ms ps Identity +type TracksFreeIxes = Simple TracksFreeIxesQM Identity + +data TracksUsedIxesOp = TracksUsedIxesOp +type TracksUsedIxesM = Simple TracksUsedIxesQM +type TracksUsedIxesQ ms ps = TracksUsedIxesQM ms ps Identity +type TracksUsedIxes = Simple TracksUsedIxesQM Identity + +data TracksIxesOp = TracksIxesOp +type TracksIxesM = Simple TracksIxesQM +type TracksIxesQ ms ps = TracksIxesQM ms ps Identity +type TracksIxes = Simple TracksIxesQM Identity + +data TracksElemsOp = TracksElemsOp +type TracksElemsM = Simple TracksElemsQM +type TracksElemsQ ms ps = TracksElemsQM ms ps Identity +type TracksElems = Simple TracksElemsQM Identity + +type instance IdxMod IndexableOp a = a +type instance IdxMod TracksElemsOp a = [a] + +indexM' = queryBuilder indexQM +index' = withTransFunc (fmap3 runIdentity) indexM' +indexM = queryBuilder $ fmap formatResult .:. indexQM +index = withTransFunc (fmap3 runIdentity) indexM +index_ = withTransFunc (fmap3 res_) index' + +freeIxesM' = queryBuilder freeIxesQM +freeIxes' = withTransFunc (fmap2 runIdentity) freeIxesM' +freeIxesM = queryBuilder $ fmap formatResult .: freeIxesQM +freeIxes = withTransFunc (fmap2 runIdentity) freeIxesM + +usedIxesM' = queryBuilder usedIxesQM +usedIxes' = withTransFunc (fmap2 runIdentity) usedIxesM' +usedIxesM = queryBuilder $ fmap formatResult .: usedIxesQM +usedIxes = withTransFunc (fmap2 runIdentity) usedIxesM +usedIxes_ = withTransFunc (fmap2 res_) usedIxes' + +ixesM' = queryBuilder ixesQM +ixes' = withTransFunc (fmap2 runIdentity) ixesM' +ixesM = queryBuilder $ fmap formatResult .: ixesQM +ixes = withTransFunc (fmap2 runIdentity) ixesM + +elemsM' = queryBuilder elemsQM +elems' = withTransFunc (fmap2 runIdentity) elemsM' +elemsM = queryBuilder $ fmap formatResult .: elemsQM +elems = withTransFunc (fmap2 runIdentity) elemsM +elems_ = withTransFunc (fmap2 res_) elems' + + + + + + +type family Tup2RTup t where + Tup2RTup () = () + Tup2RTup (t1, t2) = (t1,(t2,())) + Tup2RTup (t1, t2, t3) = (t1,(t2,(t3,()))) + Tup2RTup (t1, t2, t3, t4) = (t1,(t2,(t3,(t4,())))) + Tup2RTup a = (a,()) + +type family AppendedRT a rt where + AppendedRT a () = (a,()) + AppendedRT a (r,rt) = (r, AppendedRT a rt) + +--class AppendRT a rt where appendRT :: a -> rt -> AppendedRT a rt +--instance AppendRT a () where appendRT a _ = (a,()) +--instance AppendRT a rt => AppendRT a (r,rt) where appendRT a (r,rt) = (r,appendRT a rt) + +--class AppendRT a rt rt' | a rt -> rt', rt' -> rt a where appendRT :: a -> rt -> rt' +--instance AppendRT a () (a,()) where appendRT a _ = (a,()) +--instance AppendRT a rt rt' => AppendRT a (r,rt) (r,rt') where appendRT a (r,rt) = (r,appendRT a rt) + +type family InitRT rt where + InitRT (t,()) = () + InitRT (t,ts) = (t,InitRT ts) + +instance ( AppendRT a rt rt' + , InitRT (r, rt') ~ (r, rt) + ) => AppendRT a (r,rt) (r,rt') where appendRT a (r,rt) = (r,appendRT a rt) +instance AppendRT a () (a,()) where appendRT a _ = (a,()) +class rt ~ InitRT rt' => AppendRT a rt rt' | a rt -> rt', rt' -> a where appendRT :: a -> rt -> rt' + +resToRTup (Res ds a) = (a,ds) +res_ (Res _ a) = a +--resToRTup (Res ds a) = appendRT a ds + +formatResult = rtup2tupX . resToRTup + +class rt ~ Tup2RTup t => RTup2TupX rt t | rt -> t where rtup2tupX :: rt -> t +instance {-# OVERLAPPABLE #-} RTup2TupX () () where rtup2tupX = id +instance {-# OVERLAPPABLE #-} (Tup2RTup t1 ~ (t1,()), t1 ~ t1') => RTup2TupX (t1,()) t1' where rtup2tupX (t1,()) = t1 +instance {-# OVERLAPPABLE #-} (t1 ~ t1', t2 ~ t2') => RTup2TupX (t1,(t2,())) (t1',t2') where rtup2tupX (t1,(t2,())) = (t1,t2) +instance {-# OVERLAPPABLE #-} (t1 ~ t1', t2 ~ t2', t3 ~ t3') => RTup2TupX (t1,(t2,(t3,()))) (t1',t2',t3') where rtup2tupX (t1,(t2,(t3,()))) = (t1,t2,t3) + + + +type family PrettyCtx ms a :: Constraint where + PrettyCtx '[] a = Tup2RTup a ~ (a,()) + PrettyCtx ms a = () + +type Ctx ms m cont = (Monad m, PrettyCtx ms cont) +type Ctx2 m = (Monad m) + + + + + + + + + +-- Other utils, probably to generalize or refactor + +intercalate :: Monoid a => a -> [a] -> a +intercalate delim l = mconcat (intersperse delim l) + diff --git a/src/Data/Container/Hetero.hs b/src/Data/Container/Hetero.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container/Hetero.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE OverlappingInstances #-} +#endif + +module Data.Container.Hetero where + +--import Flowbox.Prelude hiding (Indexable, index, Repr, repr) +import Prelude +--import Control.Error.Util (hush) +import Data.Container.Class +--import Data.Constraint.Void +--import Data.Convert.Errors (TypeMismatch (TypeMismatch)) +import Data.Typeable hiding (cast) +import Unsafe.Coerce (unsafeCoerce) +import Data.Container.Poly +--import Data.Reprx + +--- === Unified values === + +--data Unified ctx where +-- Unified :: (ctx a, UnifiedEl a) => a -> Unified ctx + +--type UnifiedEl a = (Typeable a, Show a) + +---- instances + +--instance Show (Unified ctx) where +-- show (Unified a) = show a + +--instance Typeable a => MaybeConvertible (Unified ctx) TypeMismatch a where +-- tryConvert (Unified u) = if tu == ta then Right $ unsafeCoerce u +-- else Left $ TypeMismatch tu ta +-- where tu = typeOf u +-- ta = typeOf (undefined :: a) + +--instance {-# OVERLAPPABLE #-} Castable (Unified ctx) a where cast (Unified a) = unsafeCoerce a +--instance {-# OVERLAPPABLE #-} (ctx a, UnifiedEl a) => Castable a (Unified ctx) where cast = Unified + + +-- === Ptr === + +newtype Ptr i a = Ptr i deriving (Show) +newtype HPtr i m a = HPtr (Ptr i (m a)) deriving (Show) + +class PtrFrom p i | p -> i where + ptrFrom :: p -> Ptr i a + +--class (Container cont (Ptr i a) a, Container cont p a) => IsPtr cont p i a where +-- ptr :: cont -> p -> Ptr i a + +---- injective TF +--class PtrTarget (a :: * -> *) (b :: (* -> *) -> *) c | a b -> c, c -> a b --where +--instance PtrTarget (HPtr i h) a {- = -} (h (a (HPtr i h))) +--instance PtrTarget (Ptr i) a {- = -} (a (Ptr i)) + +---- instances + +--instance Repr s i => Repr s (HPtr i m a) where repr (HPtr p) = "HPtr" <+> repr p +--instance Repr s i => Repr s (Ptr i a) where repr (Ptr i) = "Ptr " <+> repr i + +--type instance IxType (Ptr i a) = a +--type instance IxType (HPtr i m a) = a + +--instance Convertible i (Ptr i a) where convert = Ptr +--instance Convertible (Ptr i a) i where convert = ptrIdx +--instance Convertible i (HPtr i m a) where convert = HPtr . convert +--instance Convertible (HPtr i m a) i where convert = ptrIdx +--instance Convertible (Ptr i (m a)) (HPtr i m a) where convert = HPtr + +class PtrIdx p i | p -> i where ptrIdx :: p -> i +instance PtrIdx (Ptr i a) i where ptrIdx (Ptr i) = i +instance PtrIdx (HPtr i m a) i where ptrIdx (HPtr p) = ptrIdx p + +instance {-# OVERLAPPABLE #-} (p ~ i) => PtrFrom p i where ptrFrom = Ptr +instance PtrFrom (Ptr i a) i where ptrFrom (Ptr i) = Ptr i + + +----- === Hetero Containers === + +--type Hetero ctx cont = HeteroContainer (cont (Unified ctx)) +--type Hetero' cont = Hetero Void1 cont + +--newtype HeteroContainer cont = HeteroContainer { _cont :: cont } deriving (Show, Functor, Foldable, Traversable) + +--makeLenses ''HeteroContainer + + +---- basic instances + +--type instance ElementByIx idx (HeteroContainer cont) = IxType idx +--type instance IndexOf el (HeteroContainer cont) = Ptr (IndexOf el cont) el + +----instance HasContainer (HeteroContainer c) (HeteroContainer c) where +---- container = id + +--instance Default cont => Default (HeteroContainer cont) where +-- def = HeteroContainer def + +--instance Monoid cont => Monoid (HeteroContainer cont) where +-- mempty = HeteroContainer mempty +-- (HeteroContainer c) `mappend` (HeteroContainer c') = HeteroContainer $ c <> c' + +---- container instances + +--type HeteroTransCtx idx ctx a cont idx' el = ( ElementOf cont ~ el +-- , el ~ Unified ctx +-- , ctx a, UnifiedEl a +-- , IsoConvertible idx idx' +-- ) + + +------class (IndexOf el cont ~ idx, ElementByIx idx cont ~ el, Measurable cont) => Container cont idx el where +------ elems :: cont -> [el] +------ indexes :: cont -> [idx] + +----instance (idx ~ Ptr (IndexOf a cont) a) => Container (HeteroContainer cont) idx a + +----instance Measurable (HeteroContainer cont) +------ TODO: TO END ^^^ + +----instance (HeteroTransCtx idx ctx a cont idx' el, Appendable' cont idx' el) +---- => Appendable' (HeteroContainer cont) idx a where +---- append' a (HeteroContainer cont) = (HeteroContainer cont', convert idx') where +---- (cont', idx') = append' (Unified a :: Unified ctx) cont + +----instance (HeteroTransCtx idx ctx a cont idx' el, Prependable cont idx' el) +---- => Prependable (HeteroContainer cont) idx a where +---- prepend' a (HeteroContainer cont) = (HeteroContainer cont', convert idx') where +---- (cont', idx') = prepend' (Unified a :: Unified ctx) cont + +----instance (HeteroTransCtx idx ctx a cont idx' el, Updatable cont idx' el) +---- => Updatable (HeteroContainer cont) idx a where +---- update idx a = fmap $ update (convert idx) (Unified a :: Unified ctx) + +----instance (HeteroTransCtx idx ctx a cont idx' el, Insertable cont idx' el) +---- => Insertable (HeteroContainer cont) idx a where +---- insert idx a = fmap $ insert (convert idx) (Unified a :: Unified ctx) +---- unsafeInsert idx a = fmap $ unsafeInsert (convert idx) (Unified a :: Unified ctx) + +----instance (HeteroTransCtx idx ctx a cont idx' el, Indexable cont idx' el, Convertible (Unified ctx) a) +---- => Indexable (HeteroContainer cont) idx a where +---- index idx (HeteroContainer cont) = convert (index (convert idx) cont :: Unified ctx) + +----instance (HeteroTransCtx idx ctx a cont idx' el, Indexable (Unsafe cont) idx' el, Convertible (Unified ctx) a) +---- => Indexable (Unsafe (HeteroContainer cont)) idx a where +---- index idx (unwrap -> (HeteroContainer cont)) = cast $ (unsafely (index $ convert idx) cont :: Unified ctx) + + +----instance (Indexable2 opts a idx el) => Indexable2 opts (Resizable s a) idx el where index2 opts idx = index2 opts idx . unwrap diff --git a/src/Data/Container/Immersed.hs b/src/Data/Container/Immersed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container/Immersed.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Container.Immersed where + +import Prelude + +import Data.Container.Class +import Data.Layer +import Control.Lens +import Control.Monad + +instance {-# OVERLAPPABLE #-} ( Monad m + , HasContainerM m (Unlayered l) + , LayeredM m l + , ImmersedM (Container (Unlayered l)) m a + ) => ImmersedM l m a where viewImmersedM' = viewLayeredM >=> viewContainerM >=> viewImmersedM' + setImmersedM' v l = flip withDivedM l $ setImmersedM' v + +instance {-# OVERLAPPABLE #-} (Monad m) => ImmersedM l m l where viewImmersedM' = return + setImmersedM' = const . return +class ImmersedM l m a where viewImmersedM' :: l -> m a + setImmersedM' :: a -> l -> m l + +viewImmersedM :: (ImmersedM (Container l) m a, HasContainerM m l, Monad m) => l -> m a +viewImmersedM = viewContainerM >=> viewImmersedM' + +setImmersedM :: (Monad m, HasContainerM m l, ImmersedM (Container l) m a) => a -> l -> m l +setImmersedM v l = do + a <- viewContainerM l + a' <- setImmersedM' v a + setContainerM a' l + +withImmersedM :: ( Monad m + , HasContainerM m l + , ImmersedM (Container l) m t + , ImmersedM (Container l) m a + ) => (t -> m a) -> l -> m l +withImmersedM f l = viewImmersedM l >>= f >>= flip setImmersedM l + +withImmersedM' :: ( Monad m + , HasContainerM m l + , ImmersedM (Container l) m a + ) => (a -> a) -> l -> m l +withImmersedM' = withImmersedM . (return .) + +dived :: (Layered a, HasContainer (Unlayered a)) => Lens' a (Container (Unlayered a)) +dived = layered . container + +withDivedM :: (Monad m, LayeredM m a, HasContainerM m (Unlayered a)) => (Container (Unlayered a) -> m (Container (Unlayered a))) -> a -> m a +withDivedM f a = flip withLayeredM a $ withContainerM f diff --git a/src/Data/Container/Instances.hs b/src/Data/Container/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container/Instances.hs @@ -0,0 +1,4 @@ +module Data.Container.Instances (module X) where + +import Data.Container.Instances.Vector.Lazy as X +import Data.Container.Instances.IntSet as X diff --git a/src/Data/Container/Instances/IntSet.hs b/src/Data/Container/Instances/IntSet.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container/Instances/IntSet.hs @@ -0,0 +1,12 @@ +module Data.Container.Instances.IntSet where + +import Prelude + +import Data.Container.Class +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.Container.List + +type instance Item IntSet = Int + +instance ToList IntSet where toList = IntSet.toList diff --git a/src/Data/Container/Instances/Vector/Lazy.hs b/src/Data/Container/Instances/Vector/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container/Instances/Vector/Lazy.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} + + +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE OverlappingInstances #-} +#endif + +module Data.Container.Instances.Vector.Lazy where + +import Prelude + +import Control.Monad.ST +import Data.Container.Class +import Data.Container.List +import Data.Default +import Data.Monoid +import Data.Typeable + +import Data.IntMap (IntMap) +import Data.Map (Map) +import Data.Maybe (fromJust) + +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import qualified Data.Vector.Unboxed as UV +import qualified Data.Vector.Unboxed.Mutable as UMV + +--import Data.Container.Poly {- x -} +--import GHC.Prim + +import qualified Data.Container.Opts as M +import Data.Container.Opts (Opt(P,N), Knowledge(..), Query(..), OptQuery(..), ModsOf, ParamsOf) +import Data.Layer +import Data.Container.Type (In) + +import Data.Container.Proxy + +------------------------------ +-- === Global instances === -- +------------------------------ + +type instance Index (V.Vector a) = Int +type instance Item (V.Vector a) = a +type instance Container (V.Vector a) = V.Vector a +type instance DataStore (V.Vector a) = V.Vector a +instance Monad m => IsContainerM m (V.Vector a) where fromContainerM = return +instance Monad m => HasContainerM m (V.Vector a) where viewContainerM = return + setContainerM = const . return + + +instance ToList (V.Vector a) where toList = V.toList + +---------------------------------- +-- === Operations instances === -- +---------------------------------- + +-- === Finite === + +-- [+] Measurable +-- [+] MinBounded +-- [+] MaxBounded + +type instance ParamsOf MeasurableOp (V.Vector a) = '[] +type instance ModsOf MeasurableOp (V.Vector a) = '[] + +type instance ParamsOf MinBoundedOp (V.Vector a) = '[] +type instance ModsOf MinBoundedOp (V.Vector a) = '[] + +type instance ParamsOf MaxBoundedOp (V.Vector a) = '[] +type instance ModsOf MaxBoundedOp (V.Vector a) = '[] + +instance Monad m => MeasurableQM_ '[] ps m (V.Vector a) where sizeM_ _ = return . Res () . V.length +instance (Monad m, idx ~ Int) => MinBoundedQM_ '[] ps m idx (V.Vector a) where minBoundM_ _ _ = return $ Res () 0 +instance (Monad m, idx ~ Int) => MaxBoundedQM_ '[] ps m idx (V.Vector a) where maxBoundM_ _ v = return $ Res () $ V.length v - 1 + + +-- === Construction === + +-- [+] Singleton +-- [+] Allocable +-- [+] Expandable +-- [+] Growable + +type instance ParamsOf SingletonOp (V.Vector a) = '[] +type instance ModsOf SingletonOp (V.Vector a) = '[M.Ixed] + +type instance ParamsOf AllocableOp (V.Vector a) = '[] +type instance ModsOf AllocableOp (V.Vector a) = '[M.Ixed] + +type instance ParamsOf ExpandableOp (V.Vector a) = '[] +type instance ModsOf ExpandableOp (V.Vector a) = '[M.Ixed] + +type instance ParamsOf GrowableOp (V.Vector a) = '[] +type instance ModsOf GrowableOp (V.Vector a) = '[M.Ixed] + +instance (Monad m, a ~ a') => SingletonQM_ '[N ] ps m a' (V.Vector a) where singletonM_ _ = return . Res () . V.singleton +instance (Monad m, a ~ a') => SingletonQM_ '[P M.Ixed] ps m a' (V.Vector a) where singletonM_ _ = return . Res (0,()) . V.singleton + +instance Monad m => AllocableQM_ '[N ] ps m (V.Vector a) where allocM_ _ i = return $ Res () $ runST $ V.unsafeFreeze =<< MV.unsafeNew i +instance Monad m => AllocableQM_ '[P M.Ixed] ps m (V.Vector a) where allocM_ _ i = return $ Res ([0..i-1],()) $ runST $ V.unsafeFreeze =<< MV.unsafeNew i + +instance Monad m => ExpandableQM_ '[N ] ps m (V.Vector a) where expandM_ _ v = return $ Res () $ runST $ V.unsafeThaw v >>= flip MV.unsafeGrow 1 >>= V.unsafeFreeze +instance Monad m => ExpandableQM_ '[P M.Ixed] ps m (V.Vector a) where expandM_ _ v = return $ Res ([V.length v],()) $ runST $ V.unsafeThaw v >>= flip MV.unsafeGrow 1 >>= V.unsafeFreeze + +instance Monad m => GrowableQM_ '[N ] ps m (V.Vector a) where growM_ _ i v = return $ Res () $ runST $ V.unsafeThaw v >>= flip MV.unsafeGrow i >>= V.unsafeFreeze +instance Monad m => GrowableQM_ '[P M.Ixed] ps m (V.Vector a) where growM_ _ i v = return $ Res ([V.length v .. V.length v + i - 1],()) $ runST $ V.unsafeThaw v >>= flip MV.unsafeGrow i >>= V.unsafeFreeze + + +-- === Modification === +-- [+] Appendable +-- [+] Prependable +-- [+] Addable +-- [+] Removable +-- [+] Insertable +-- [+] Freeable + + +type instance ParamsOf AppendableOp (V.Vector a) = '[] +type instance ModsOf AppendableOp (V.Vector a) = '[M.Ixed] + +type instance ParamsOf PrependableOp (V.Vector a) = '[] +type instance ModsOf PrependableOp (V.Vector a) = '[M.Ixed] + +type instance ParamsOf AddableOp (V.Vector a) = '[] +type instance ModsOf AddableOp (V.Vector a) = '[M.Ixed] + +type instance ParamsOf RemovableOp (V.Vector a) = '[M.Try] +type instance ModsOf RemovableOp (V.Vector a) = '[M.Ixed] + +type instance ParamsOf InsertableOp (V.Vector a) = '[] +type instance ModsOf InsertableOp (V.Vector a) = '[M.Ixed] + +type instance ParamsOf FreeableOp (V.Vector a) = '[] +type instance ModsOf FreeableOp (V.Vector a) = '[] + +instance (Monad m, a ~ a') => AppendableQM_ '[N ] ps m a' (V.Vector a) where appendM_ _ el v = (return . Res ()) $ V.snoc v el +instance (Monad m, a ~ a') => AppendableQM_ '[P M.Ixed] ps m a' (V.Vector a) where appendM_ _ el v = (return . Res (size v,())) $ V.snoc v el + +instance (Monad m, a ~ a') => PrependableQM_ '[N ] ps m a' (V.Vector a) where prependM_ _ el v = (return . Res ()) $ V.cons el v +instance (Monad m, a ~ a') => PrependableQM_ '[P M.Ixed] ps m a' (V.Vector a) where prependM_ _ el v = (return . Res (0,())) $ V.cons el v + +instance (Monad m, a ~ a') => AddableQM_ '[N ] ps m a' (V.Vector a) where addM_ _ el v = (return . Res ()) $ V.snoc v el +instance (Monad m, a ~ a') => AddableQM_ '[P M.Ixed] ps m a' (V.Vector a) where addM_ _ el v = (return . Res (size v,())) $ V.snoc v el + +instance (Monad m, Eq a, a ~ a') => RemovableQM_ '[N ] '[P M.Try] m a' (V.Vector a) where removeM_ _ el v = case idx of + Just i -> (return . Res ()) $ V.slice 0 (i-1) v <> V.slice i (size v - i) v + Nothing -> fail "Element not found" + where idx = V.findIndex (== el) v +instance (Monad m, Eq a, a ~ a') => RemovableQM_ '[P M.Ixed] '[P M.Try] m a' (V.Vector a) where removeM_ _ el v = case idx of + Just i -> (return . Res (i,())) $ V.slice 0 (i-1) v <> V.slice i (size v - i) v + Nothing -> fail "Element not found" + where idx = V.findIndex (== el) v + + +instance (Monad m, a ~ a', idx ~ Int) => InsertableQM_ '[N ] ps m idx a' (V.Vector a) where insertM_ _ idx el v = (return . Res ()) $ (V.//) v [(idx,el)] +instance (Monad m, a ~ a', idx ~ Int) => InsertableQM_ '[P M.Ixed] ps m idx a' (V.Vector a) where insertM_ _ idx el v = (return . Res (idx,())) $ (V.//) v [(idx,el)] + + +instance (Monad m, idx ~ Int) => FreeableQM_ '[] ps m idx (V.Vector a) where freeM_ _ idx v = (return . Res ()) $ (V.//) v [(idx,error $ "uninitialized element at index " <> show idx)] + + + +-- === Indexing === + +-- [+] Indexable +-- [-] TracksFreeIxes +-- [-] TracksUsedIxes +-- [+] TracksIxes +-- [+] TracksElems + +type instance ParamsOf IndexableOp (V.Vector a) = '[M.Unchecked, M.Try] +type instance ModsOf IndexableOp (V.Vector a) = '[M.Ixed] + +type instance ParamsOf TracksIxesOp (V.Vector a) = '[] +type instance ModsOf TracksIxesOp (V.Vector a) = '[] + +instance (Monad m, a ~ a', idx ~ Int, Cond2 unchecked, Cond2 try) => IndexableQM_ '[N ] '[unchecked, try] m idx a' (V.Vector a) where indexM_ _ idx v = Res () <$> checkedBoundsIfM2 (Proxy :: Proxy unchecked) (Proxy :: Proxy try) idx v (V.unsafeIndex v idx) +instance (Monad m, a ~ a', idx ~ Int, Cond2 unchecked, Cond2 try) => IndexableQM_ '[P M.Ixed] '[unchecked, try] m idx a' (V.Vector a) where indexM_ _ idx v = Res (idx,()) <$> checkedBoundsIfM2 (Proxy :: Proxy unchecked) (Proxy :: Proxy try) idx v (V.unsafeIndex v idx) + +instance (Monad m, idx ~ Int) => TracksIxesQM_ '[] ps m idx (V.Vector a) where ixesM_ _ v = (return . Res ()) $ [0 .. size v -1] +instance (Monad m, a ~ a') => TracksElemsQM_ '[] ps m a' (V.Vector a) where elemsM_ _ v = (return . Res ()) $ V.toList v + + + +---- missing instances ---- + +instance Default (V.Vector a) where def = mempty + + +--- Utils (TODO: refactor) + +failT2 p = ifT2 p fail error + +checkBounds2 i v l r = if i > max || i < 0 then l ("index " <> show i <> " out of bounds x[0," <> show max <> "]") else r where max = size v - 1 +checkBoundsM2 p idx v = checkBounds2 idx v (const . failT2 p) return +checkedBoundsIfM2 unchecked try idx v = checkedIfM2 unchecked (checkBoundsM2 try idx v) + +checkedIfM2 p = ifT2 p return + + +class Cond2 (opt :: Opt *) where ifT2 :: Proxy opt -> a -> a -> a +instance Cond2 (P a) where ifT2 _ = const +instance Cond2 N where ifT2 _ = flip const + + diff --git a/src/Data/Container/List.hs b/src/Data/Container/List.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container/List.hs @@ -0,0 +1,42 @@ +module Data.Container.List where + +import Data.Container.Class + +import Prelude + +import Control.Lens +import qualified GHC.Exts as GHC +import qualified Data.Vector as V +import qualified Data.Text as Text +import Data.Text (Text) +import qualified Data.Text.Lazy as LazyText + +type LazyText = LazyText.Text + + +class FromList l where fromList :: [Item l] -> l + default fromList :: (GHC.IsList l, GHC.Item l ~ Item l) + => [Item l] -> l + fromList = GHC.fromList + +class ToList l where toList :: l -> [Item l] + default toList :: (GHC.IsList l, GHC.Item l ~ Item l) + => l -> [Item l] + toList = GHC.toList + +type IsList l = (FromList l, ToList l) + +asList :: IsList a => Iso' a [Item a] +asList = iso toList fromList + + +-- === Instances === + +type instance Item Text = Char +instance ToList Text where toList = Text.unpack +instance FromList Text where fromList = Text.pack + + +type instance Item LazyText = Char +instance ToList LazyText where toList = LazyText.unpack +instance FromList LazyText where fromList = LazyText.pack diff --git a/src/Data/Container/Opts.hs b/src/Data/Container/Opts.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container/Opts.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# LANGUAGE PolyKinds #-} + + +module Data.Container.Opts where + +import Prelude +import Type.Bool +import Data.Typeable + + +------------------ +-- === Opts === -- +------------------ + +type family ParamsOf op cont :: [*] +type family ModsOf op cont :: [*] + + +data Opt a = P a -- Provided + | N -- Not provided + deriving (Show) + +-- Knowledge + +data Knowledge a = Known a + | Unknown + deriving (Show) + +-- Mods + +data Ixed = Ixed + +-- Parameters + +data Safe = Safe +data Unchecked = Unchecked +data Unsafe = Unsafe +data Inplace = Inplace + +-- Formatters + +data Try = Try +data Raw = Raw + + + + +------------------------- +type family MatchOpts (provided :: [*]) (selected :: [*]) :: [Opt *] where + MatchOpts (p ': ps) sel = (p `CheckIfKnown` sel) ': MatchOpts ps sel + MatchOpts '[] sel = '[] + + +type family CheckIfKnown flag flags :: Opt * where + CheckIfKnown f (f ': fs) = P f + CheckIfKnown f (f' ': fs) = CheckIfKnown f fs + CheckIfKnown f '[] = N + + +------------------------- +-- === Opt queries === -- +------------------------- + +data Query (mods :: [*]) (params :: [*]) = Query +data OptQuery (mods :: [Opt *]) (params :: [Opt *]) = OptQuery + + + + + +------------------------ +-- === OptBuilder === -- +------------------------ + +newtype OptBuilder (mods :: [*]) (params :: [*]) a = OptBuilder a deriving (Show, Functor) +type OptBuilderBase = OptBuilder '[] '[] + +class FuncTrans mods params f a | a mods params -> f where transFunc :: OptBuilder mods params f -> a +instance (mods ~ mods', params ~ params', f ~ f') => FuncTrans mods params f (OptBuilder mods' params' f') where transFunc = id +instance (f ~ (Query mods params -> a -> b)) => FuncTrans mods params f (a -> b) where transFunc (OptBuilder f) = f Query + +class FuncBuilder f a | a -> f where buildFunc :: f -> a +instance {-# OVERLAPPABLE #-} (f ~ a, g ~ b) => FuncBuilder (f -> g) (a -> b) where buildFunc = id +instance {-# OVERLAPPABLE #-} (t ~ (f -> g), mods ~ '[], params ~ '[]) => FuncBuilder (f -> g) (OptBuilder mods params t) where buildFunc = OptBuilder + +-- utils + +optBuilder :: f -> OptBuilderBase f +optBuilder = OptBuilder + + +queryBuilder :: FuncTrans '[] '[] f a => f -> a +queryBuilder = transFunc . optBuilder + +extendOptBuilder :: Query newMods newParams + -> Query collectedMods collectedParams + -> OptBuilder mods params a + -> OptBuilder (Concat newMods (Concat collectedMods mods )) + (Concat newParams (Concat collectedParams params)) + a +extendOptBuilder _ _ (OptBuilder a) = OptBuilder a + +appFunc :: (f -> g) -> OptBuilder ms ps f -> OptBuilder ms ps g +appFunc = fmap + +withTransFunc f = transFunc . appFunc f + +-------------------------------- + + +type Concat lst lst' = Concat' (Reverse lst) lst' + +type family Concat' lst lst' where + Concat' (x ': xs) lst = Concat' xs (x ': lst) + Concat' '[] lst = lst + + + + +type Reverse lst = Reverse' lst '[] + +type family Reverse' (lst :: [*]) (lst' :: [*]) where + Reverse' '[] lst = lst + Reverse' (l ': ls) lst = Reverse' ls (l ': lst) + + + +---------------------------------- + +type family OptData provided datas opt where + OptData (o ': ps) (d,ds) o = d + OptData (p ': ps) (d,ds) o = OptData ps ds o + +type family QueryData provided query datas where + QueryData p (q ': qs) d = (OptData p d q, QueryData p qs d) + QueryData p '[] d = () + + +class GetOptData (provided :: [*]) datas opt where getOptData :: Proxy provided -> datas -> Proxy opt -> OptData provided datas opt +instance {-# OVERLAPPABLE #-} ( datas ~ (a,as) + , GetOptData ps as o + , OptData ps as o ~ OptData (p ': ps) (a, as) o + ) => GetOptData (p ': ps) datas o where getOptData _ (a,as) o = getOptData (Proxy :: Proxy ps) as o +instance {-# OVERLAPPABLE #-} datas ~ (a,as) => GetOptData (p ': ps) datas p where getOptData _ (a,as) _ = a + + +class GetQueryData (provided :: [*]) (query :: [*]) datas where getQueryData :: Proxy provided -> Proxy query -> datas -> QueryData provided query datas +instance {-# OVERLAPPABLE #-} (GetQueryData p qs datas, GetOptData p datas q) + => GetQueryData p (q ': qs) datas where getQueryData p q datas = (getOptData p datas (Proxy :: Proxy q), getQueryData p (Proxy :: Proxy qs) datas) +instance {-# OVERLAPPABLE #-} GetQueryData p '[] datas where getQueryData _ _ _ = () + + +(.:) = (.) . (.) + + +ixed = queryBuilder $ transFunc .: extendOptBuilder (Query :: Query '[ Ixed ] '[] ) +raw = queryBuilder $ transFunc .: extendOptBuilder (Query :: Query '[] '[ Raw ]) +try = queryBuilder $ transFunc .: extendOptBuilder (Query :: Query '[] '[ Try ]) +unchecked = queryBuilder $ transFunc .: extendOptBuilder (Query :: Query '[] '[ Unchecked ]) +unsafe = queryBuilder $ transFunc .: extendOptBuilder (Query :: Query '[] '[ Unsafe ]) +inplace = queryBuilder $ transFunc .: extendOptBuilder (Query :: Query '[] '[ Inplace ]) diff --git a/src/Data/Container/Parametrized.hs b/src/Data/Container/Parametrized.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container/Parametrized.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} + +module Data.Container.Parametrized where + + +--import Prologue +--import Data.Container.Class +--import Data.Container.Poly +--import Data.Container.Weak +--import Data.Layer + + +--newtype Parametrized t (m :: * -> *) a = Parametrized { _parametrized :: t (m a) } deriving (Show, Functor, Traversable, Foldable, FromList, Monoid, Default) + +--type instance Item (Parametrized t m a) = Item (Unwrapped (Parametrized t m a)) +--type instance ModsOf (cls :: k) (Parametrized t m a) = ModsOf cls (Unwrapped (Parametrized t m a)) +--type instance DataStoreOf (Parametrized t m a) = DataStoreOf (Unwrapped (Parametrized t m a)) +--type instance ContainerOf (Parametrized t m a) = ContainerOf (Unwrapped (Parametrized t m a)) + +---- Wrappers & layers + +--type instance Unlayered (Parametrized t m a) = Unwrapped (Parametrized t m a) +--instance Layered (Parametrized t m a) +--instance Wrapped (Parametrized t m a) where +-- type Unwrapped (Parametrized t m a) = t (m a) +-- _Wrapped' = iso (\(Parametrized c) -> c) Parametrized + + +---- Instances + +--instance IsContainer (t (m a)) => IsContainer (Parametrized t m a) where fromContainer = Parametrized . fromContainer +--instance HasContainer (t (m a)) => HasContainer (Parametrized t m a) where container = layered . container + +--type instance ElementOf (Parametrized t m a) = ElementOf (t (m a)) +--type instance IndexOf el (Parametrized t m a) = IndexOf el (t (m a)) + +--type instance HomoIndexOf (Parametrized t m) = HomoIndexOf m + + +---- Lenses + +--makeLenses ''Parametrized diff --git a/src/Data/Container/Poly.hs b/src/Data/Container/Poly.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container/Poly.hs @@ -0,0 +1,611 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Container.Poly where + +--import Prologue hiding (Ixed, Indexed, Simple) +--import Data.TypeLevel.List (In) +--import Data.Typeable +--import GHC.Prim +--import Type.Bool +import qualified Data.Container.Opts as Mods +--import Data.Container.Mods (FilterMutable, filterMutable) + + + +--type family AppendLst a lst where AppendLst a '[] = '[a] +-- AppendLst a (l ': ls) = l ': AppendLst a ls + + + +-------------------- + +--type family CmpLst (lst :: [k]) (lst' :: [k']) :: [Bool] where +-- CmpLst (l ': ls) (l ': ls') = (True ': CmpLst ls ls') +-- CmpLst (l ': ls) (l' ': ls') = (False ': CmpLst ls ls') +-- CmpLst '[] '[] = '[] + +--type family LstIn (lst :: [*]) (lst' :: [*]) :: [Bool] where +-- LstIn (l ': ls) lst = In l lst ': LstIn ls (Remove l lst) +-- LstIn ls '[] = '[] +-- LstIn '[] lst = '[] + + +--type family Remove (a :: k) (cont :: c) :: c +--type instance Remove (a :: k) ((t ': ts) :: [k]) = If (a :== t) ts (t ': Remove a ts) +--type instance Remove (a :: k) '[] = '[] + + +--type family ModsOf (inst :: k) cont :: [*] + +--data InstMods (inst :: k) (mods :: [Bool]) = InstMods +--data InstMods2 (inst :: k) (mods :: [Bool]) (cont :: *) = InstMods2 +--data InstModsX (inst :: k) (query :: [*]) (mods :: [Bool]) (cont :: *) = InstModsX + + + + + + + + +--newtype Tagged t a = Tagged { fromTag :: a } deriving (Show) + +--tagged :: Proxy t -> a -> Tagged t a +--tagged _ = Tagged + +--type family FillData (layout :: [*]) datas where FillData (t ': ts) datas = (GetData t datas, FillData ts datas) +-- FillData '[] datas = () + +--type family GetData (tag :: *) datas where GetData tag (Tagged tag a, ds) = a +-- GetData tag (Tagged tag' a, ds) = GetData tag ds + +--type family TaggedCont (tags :: [*]) a +--type instance TaggedCont '[] () = () +--type instance TaggedCont (t ': ts) (a,as) = (Tagged t a, TaggedCont ts as) + +--class Taggable tags cont where +-- taggedCont :: Proxy tags -> cont -> TaggedCont tags cont + +--instance {-# OVERLAPPABLE #-} Taggable '[] () where taggedCont _ _ = () +--instance {-# OVERLAPPABLE #-} Taggable ts as => Taggable (t ': ts) (a,as) where taggedCont _ (a,as) = (Tagged a, taggedCont (Proxy :: Proxy ts) as) + +--class DataFillable (layout :: [*]) datas where fillData :: Proxy layout -> datas -> FillData layout datas +--instance {-# OVERLAPPABLE #-} (DataGettable t datas, DataFillable ts datas) => DataFillable (t ': ts) datas where fillData _ ds = (getData (Proxy :: Proxy t) ds, fillData (Proxy :: Proxy ts) ds) +--instance {-# OVERLAPPABLE #-} DataFillable '[] datas where fillData _ _ = () + +--class DataGettable tag datas where getData :: Proxy tag -> datas -> GetData tag datas +--instance {-# OVERLAPPABLE #-} DataGettable tag (Tagged tag a, ds) where getData _ = fromTag . fst +--instance {-# OVERLAPPABLE #-} (DataGettable tag ds, GetData tag (Tagged tag' a, ds) ~ GetData tag ds) => DataGettable tag (Tagged tag' a, ds) where getData t = getData t . snd + + + +--type family MappedByTag tag a l +--type instance MappedByTag t a () = () +--type instance MappedByTag t a (Tagged t' a', ls) = If (t :== t') (Tagged t a , MappedByTag t a ls) +-- (Tagged t' a', MappedByTag t a ls) + +--class MapByTag t a b l | t l -> a where mapByTag :: Proxy t -> (a -> b) -> l -> MappedByTag t b l +--class MapByTag' t a b l where mapByTag' :: Proxy t -> (a -> b) -> l -> MappedByTag t b l +--instance {-# OVERLAPPABLE #-} (MapByTag' t a b l, a ~ a') => MapByTag t a b (Tagged t a', l ) where mapByTag t f (Tagged a, l) = (Tagged $ f a, mapByTag' t f l) +--instance {-# OVERLAPPABLE #-} (MapByTag t a b l, MappedByTag t b (Tagged t' a', l) ~ (Tagged t' a', MappedByTag t b l)) => MapByTag t a b (Tagged t' a', l ) where mapByTag t f (ta , l) = (ta , mapByTag t f l) +--instance {-# OVERLAPPABLE #-} (MapByTag' t a b l, a ~ a') => MapByTag' t a b (Tagged t a', l ) where mapByTag' t f (Tagged a, l) = (Tagged $ f a, mapByTag' t f l) +--instance {-# OVERLAPPABLE #-} (MapByTag' t a b l, MappedByTag t b (Tagged t' a', l) ~ (Tagged t' a', MappedByTag t b l)) => MapByTag' t a b (Tagged t' a', l ) where mapByTag' t f (ta , l) = (ta , mapByTag' t f l) +--instance MapByTag' t a b () where mapByTag' _ _ _ = () + + + + +--type I = InstMods2 +--type I2X = InstModsX + +--type family UpdateQuery instMods guery where +-- UpdateQuery (InstModsX inst q m cont) q'= InstModsX inst q' (LstIn (ModsOf inst cont) q') cont + + + + + +--rebaseSpecX :: InstModsX inst q mods cont -> InstModsX inst' q (LstIn (ModsOf inst' cont) q) cont +--rebaseSpecX _ = InstModsX + +--polySpecX :: InstModsX inst q mods cont -> InstModsX inst q (LstIn (ModsOf inst cont') q) cont' +--polySpecX _ = InstModsX +----type family Rebase mods base where Rebase (InstMods2 inst mods old) new = InstMods2 inst mods new + +--type family InstQuery (inst :: * -> Constraint) :: [*] + +--query :: InstModsX inst q mods cont -> Proxy q +--query _ = Proxy + + + + + + + +--optBuilder :: a -> OptBuilderBase a +--optBuilder = OptBuilder + +--type OptBuilderBase = OptBuilder '[] + + + +--newtype OptBuilder (opts :: [*]) a = OptBuilder a deriving (Functor) + +--class FuncBuilder f a | a -> f where +-- buildFunc :: f -> a + +--class FuncTrans opts f a | a opts -> f where +-- transFunc :: OptBuilder opts f -> a + +--instance {-# OVERLAPPABLE #-} (f ~ a, g ~ b) => FuncBuilder (f -> g) (a -> b) where buildFunc = id +--instance {-# OVERLAPPABLE #-} (t ~ (f -> g), opts ~ '[]) => FuncBuilder (f -> g) (OptBuilder opts t) where buildFunc = OptBuilder + +--instance (opts ~ opts', f ~ f') => FuncTrans opts f (OptBuilder opts' f') where transFunc = id +--instance (f ~ (Proxy opts -> a -> b)) => FuncTrans opts f (a -> b) where transFunc (OptBuilder f) = f Proxy + + + + + +--extendOptBuilder :: Proxy opt -> Proxy opts' -> OptBuilder opts a -> OptBuilder (opt ': (Concat opts' opts)) a +--extendOptBuilder _ _ (OptBuilder a) = OptBuilder a + + + + +---------------- + + + + + +--type family Selected (b :: [Bool]) (lst :: [*]) :: [*] where +-- Selected ('True ': b) (l ': ls) = l ': Selected b ls +-- Selected ('False ': b) (l ': ls) = Selected b ls +-- Selected '[] lst = '[] +-- Selected s lst = '[] + + + +--data Query (q :: [*]) (m :: [Bool]) = Query + + +--data NA = NA +--data Info (idx :: *) (el :: *) (cls :: k) (cont :: *) = Info + +--type family InfoIdx i where InfoIdx (Info idx el cls cont) = idx +--type family InfoEl i where InfoEl (Info idx el cls cont) = el +--type family InfoCls i where InfoCls (Info idx el cls cont) = cls +--type family InfoCont i where InfoCont (Info idx el cls cont) = cont + +--type RawInfo = Info NA NA +--type IxedInfo idx = Info idx NA +--type ElInfo el = Info NA el +--type IxedElInfo idx el = Info idx el + + + +--type family ElementOf cont +--type family IndexOf el cont +--type family HomoIndexOf (m :: * -> *) :: * +--type family ElementByIx idx cont +--type family IxType idx + +--type IndexOf' cont = IndexOf (ElementOf cont) cont + +---- === Results === + + + +--type family SelTags (info :: *) (s :: [Bool]) where SelTags (Info idx el cls cont) s = QueryData (Info idx el cls (DataStoreOf cont)) (Selected s (FilterMutable (ModsOf cls cont))) + + + + + + + + + +--type IxedData cls idx = If (IxedMode cls :== Single) idx [idx] + +--type family QueryData (info :: *) (query :: [*]) :: * where +-- QueryData info '[] = () +-- QueryData info (q ': qs) = (ModData q info, QueryData info qs) + +--type family ModData mod info +--type instance ModData Mods.Ixed (Info idx el cls cont) = IxedData cls ( +-- If (idx :== NA) ( +-- --If (el :== NA) +-- (IndexOf' cont) +-- -- (IndexOf el cont) +-- ) idx +-- ) + + + + + +--type ComputeSelection (cls :: k) (cont :: *) (q :: [*]) = LstIn (ModsOf cls cont) q +--type AssumeQuery i q s = QueryData (DataStoreInfo i) (FilterMutable q) ~ SelTags i s + + + + +--runModsF :: ComputeSelection cls cont q ~ s => (Proxy (q :: [*])) -> (Query q s -> Info idx el cls cont -> sig) -> sig +--runModsF _ f = f Query Info + + +--runModsF' = flip runModsF + + + +--type family ContainerOf a +--class HasContainer a where +-- container :: Lens' a (ContainerOf a) + +--type family DataStoreOf a + +--class HasDataStore a where +-- dataStore :: Lens' a (DataStoreOf a) + +--class HasDataStore a => IsDataStore a where +-- fromDataStore :: DataStoreOf a -> a + + + +--type family InfoSelection i q where InfoSelection (Info idx el cls cont) q = ComputeSelection cls cont q +--type family DataStoreInfo i where DataStoreInfo (Info idx el cls cont) = Info idx el cls (DataStoreOf cont) + + + +--type family InfoInst info q m :: Constraint where +-- InfoInst (Info NA NA cls cont) q m = cls cont m q (ComputeSelection cls cont q) +-- InfoInst (Info NA el cls cont) q m = cls el cont m q (ComputeSelection cls cont q) +-- InfoInst (Info idx NA cls cont) q m = cls idx cont m q (ComputeSelection cls cont q) +-- InfoInst (Info idx el cls cont) q m = cls idx el cont m q (ComputeSelection cls cont q) + + + + + + +------ + + + + + + +--type family Ixed (op :: k) :: k where Ixed (cls q (m :: * -> *) :: * -> Constraint) = cls (AppendLst Mods.Ixed q) m +-- Ixed (cls q :: (* -> *) -> * -> Constraint) = cls (AppendLst Mods.Ixed q) + + + +--type family Unchecked (op :: k) :: k where Unchecked (cls q (m :: * -> *) :: * -> Constraint) = cls (AppendLst Mods.Unchecked q) m +-- Unchecked (cls q :: (* -> *) -> * -> Constraint) = cls (AppendLst Mods.Unchecked q) + + + + + + + + +type family Ixed (op :: k) :: k where + Ixed (op (ms :: [*]) (ps :: [*])) = op (Mods.Ixed ': ms) ps + Ixed (op (ms :: [*]) (ps :: [*]) (m :: * -> *)) = op (Mods.Ixed ': ms) ps m + +---- === Concatenation === + + + + + + + + +--type family IxedMode (a :: k) :: IxedType + +--data IxedType = Multi +-- | Single +-- deriving (Show) + + + +----type family ClassOf (a :: *) :: k + +---------------------------------- + + + + + + + +--newtype NestedFunctor m n a = NestedFunctor { fromNestedFunctor :: m (n a)} deriving (Show) +--instance (Functor m, Functor n) => Functor (NestedFunctor m n) where fmap f = NestedFunctor . (fmap $ fmap f) . fromNestedFunctor + + +--nested :: (Functor m, Functor n) => Lens a b c d -> (c -> m (n d)) -> (a -> m (n b)) +--nested l f = fromNestedFunctor . l (fmap NestedFunctor f) + + + + + +--data Result d r = Result d r deriving (Show, Functor) + +---- Result utils + +--simple' = Result () +--res = Result . (,()) +--resM = return .: res +--simpleM = return . simple' + +--withResData :: (d -> (out, d')) -> Result d r -> (out, Result d' r) +--withResData f (Result d r) = (out, Result d' r) where +-- (out, d') = f d + +--withResData_ :: (d -> d') -> Result d r -> Result d' r +--withResData_ = flattenMod withResData + +--splitResData :: Result (d,ds) r -> (d, Result ds r) +--splitResData = withResData id + +--flattenMod :: Functor f => (f ((), a) -> b -> (x, c)) -> f a -> b -> c +--flattenMod f = snd .: (f . fmap ((),)) + + + +----type Unique lst = Reverse (Unique' lst '[]) +--type Unique lst = (Unique2' lst) + +--type family Unique' (lst :: [*]) (reg :: [*]) where +-- Unique' '[] reg = reg +-- Unique' (l ': ls) reg = Unique' ls (If (l `In` reg) reg (l ': reg)) + +--type family Unique2' (lst :: [*]) where +-- Unique2' '[] = '[] +-- Unique2' (l ': ls) = l ': Unique2' (Remove l ls) + + + + +--uniqueProxy :: Proxy a -> Proxy (Unique a) +--uniqueProxy _ = Proxy + + + + + + +--newtype Flipped t a b = Flipped { fromFlipped :: t b a } deriving Show + +--instance Functor (Flipped Result r) where fmap f (Flipped (Result d r)) = Flipped (Result (f d) r) + + +--withFlipped f = fromFlipped . f . Flipped + + + +--foo f (info :: Proxy (cls :: k)) (q :: Proxy (q :: [*])) (tc :: cont) = out where +-- tc2 = runModsF' f (uniqueProxy q) tc +-- tc3 = withFlipped (fmap $ taggedCont (Proxy :: Proxy (Selected (ComputeSelection cls cont q) (FilterMutable (ModsOf cls cont))) )) <$> tc2 +-- out = tc3 + +----bar :: OpCtx ExpandableInfo2 q m t => Proxy q -> t -> m (Result (MyResult ExpandableInfo2 q t) t) +--bar f info q t = out where +-- q' = filterMutable q +-- cont = view container t +-- tgdr = foo f info q cont +-- tgdr' = (fmap . fmap) (\c -> t & container .~ c) tgdr +-- out = withFlipped (fmap (fillData q')) <$> tgdr' + + +--barTx f (cls :: Proxy (cls :: k)) (q :: Proxy (q :: [*])) (t :: t) = withFlipped (fmap (fillData (filterMutable q))) <$> nested container tgdr t where +-- tgdr c = withFlipped (fmap $ taggedCont (Proxy :: Proxy (Selected (ComputeSelection cls (ContainerOf t) q) (FilterMutable (ModsOf cls (ContainerOf t)))) )) <$> f (uniqueProxy q) c + + +--barTy f (cls :: Proxy (cls :: k)) (q :: Proxy (q :: [*])) (t :: t) = withFlipped (fmap (fillData (filterMutable q))) <$> tgdr (view container t) where +-- tgdr c = withFlipped (fmap $ taggedCont (Proxy :: Proxy (Selected (ComputeSelection cls (ContainerOf t) q) (FilterMutable (ModsOf cls (ContainerOf t)))) )) <$> f (uniqueProxy q) c + +----bar2z f (cls :: Proxy (cls :: k)) (q :: Proxy (q :: [*])) (t :: t) = withFlipped (fmap (fillData (filterMutable q))) <$> tgdr (view container t) where +---- tgdr c = withFlipped (fmap $ taggedCont (Proxy :: Proxy (Selected (ComputeSelection cls (ContainerOf t) q) (FilterMutable (ModsOf cls (ContainerOf t)))) )) <$> f (uniqueProxy q) c + + + +--type family AssumeRtupConv q t :: Constraint where AssumeRtupConv q t = If' (Mods.FilterMutable q :== '[]) (AsRTup t ~ (t,())) () + +--type family OpCtx info q m t where OpCtx (Info idx el cls) q m t = ((Functor m, +-- HasContainer t, +-- DataFillable +-- (FilterMutable q) +-- (TaggedCont +-- (Selected +-- (LstIn +-- (ModsOf cls (ContainerOf t)) q) +-- (FilterMutable +-- (ModsOf cls (ContainerOf t)))) +-- (QueryData +-- (Info idx el cls (DataStoreOf t)) +-- (Selected +-- (LstIn +-- (ModsOf cls (ContainerOf t)) +-- (Unique q)) +-- (FilterMutable +-- (ModsOf +-- cls (ContainerOf t)))))), +-- Taggable +-- (Selected +-- (LstIn +-- (ModsOf cls (ContainerOf t)) q) +-- (FilterMutable +-- (ModsOf cls (ContainerOf t)))) +-- (QueryData +-- (Info idx el cls (DataStoreOf t)) +-- (Selected +-- (LstIn +-- (ModsOf cls (ContainerOf t)) +-- (Unique q)) +-- (FilterMutable +-- (ModsOf +-- cls (ContainerOf t))))), +-- QueryData +-- (Info idx el cls (DataStoreOf t)) +-- (FilterMutable (Unique q)) +-- ~ QueryData +-- (Info idx el cls (DataStoreOf t)) +-- (Selected +-- (LstIn +-- (ModsOf cls (ContainerOf t)) +-- (Unique q)) +-- (FilterMutable +-- (ModsOf cls (ContainerOf t)))), +-- QueryData +-- (Info idx el cls (DataStoreOf t)) +-- (FilterMutable q) +-- ~ FillData +-- (FilterMutable q) +-- (TaggedCont +-- (Selected +-- (LstIn +-- (ModsOf cls (ContainerOf t)) +-- q) +-- (FilterMutable +-- (ModsOf +-- cls (ContainerOf t)))) +-- (QueryData +-- (Info idx el cls (DataStoreOf t)) +-- (Selected +-- (LstIn +-- (ModsOf +-- cls (ContainerOf t)) +-- (Unique q)) +-- (FilterMutable +-- (ModsOf +-- cls +-- (ContainerOf t))))))), + +-- -- manual +-- Functor m, +-- AssumeRtupConv q t, +-- IsContainer t, +-- InfoInst (Info idx el cls (ContainerOf t)) (Unique q) m, +-- DataStoreOf (ContainerOf t) ~ DataStoreOf t, +-- (QueryData (Info idx el cls (DataStoreOf t)) (FilterMutable q) ~ QueryData (Info idx el cls (DataStoreOf t)) (FilterMutable q))) + + +--type family TransCheck q info info' t where +-- TransCheck q (Info idx el cls) info' t = (FillData +-- (FilterMutable q) +-- (TaggedCont +-- (Selected +-- (LstIn (ModsOf cls (ContainerOf t)) q) +-- (FilterMutable (ModsOf cls (ContainerOf t)))) +-- (QueryData +-- (Info idx el cls (DataStoreOf t)) +-- (Selected +-- (LstIn +-- (ModsOf cls (ContainerOf t)) +-- (Unique q)) +-- (FilterMutable (ModsOf cls (ContainerOf t)))))) +-- ~ QueryData +-- (info' (DataStoreOf t)) (FilterMutable q)) + + + + + + +----type family Test (a :: k) where Test a = (If a :== (t1,t2)) True True + + +----type family Match + +--class IsTuple a (is :: Bool) | a -> is + +--instance {-# OVERLAPPABLE #-} is ~ False => IsTuple a is +--instance IsTuple () True +--instance IsTuple (t1,t2) True +--instance IsTuple (t1,t2,t3) True +--instance IsTuple (t1,t2,t3,t4) True +--instance IsTuple (t1,t2,t3,t4,t5) True +--instance IsTuple (t1,t2,t3,t4,t5,t6) True +--instance IsTuple (t1,t2,t3,t4,t5,t6,t7) True +--instance IsTuple (t1,t2,t3,t4,t5,t6,t7,t8) True +--instance IsTuple (t1,t2,t3,t4,t5,t6,t7,t8,t9) True + +---- FIXME [WD]: below ToTupCtx* refer to need of AssumeRtupConv function, which adds special case context when we are returning only single value from Rtuple (t,()) +---- It is not seen properly byGHC though +----type family ToTupCtx a :: Constraint where +---- ToTupCtx (t,()) = (AsRTup t ~ (t,())) +---- ToTupCtx t = () + +----type family ToTupCtx2 a :: Constraint where +---- ToTupCtx2 (t1,t2) = () +---- ToTupCtx2 (t1,t2,t3) = () +---- ToTupCtx2 (t1,t2,t3,t4) = () +---- ToTupCtx2 (t1,t2,t3,t4,t5) = () +---- ToTupCtx2 (t1,t2,t3,t4,t5,t6) = () +---- ToTupCtx2 (t1,t2,t3,t4,t5,t6,t7) = () +---- ToTupCtx2 (t1,t2,t3,t4,t5,t6,t7,t8) = () +---- ToTupCtx2 (t1,t2,t3,t4,t5,t6,t7,t8,t9) = () +---- ToTupCtx2 t = (AsRTup t ~ (t,())) + +-- ---- Utils + +--type family AsTup a +--type instance AsTup () = () +--type instance AsTup (t1,()) = t1 +--type instance AsTup (t1,(t2,())) = (t1,t2) +--type instance AsTup (t1,(t2,(t3,()))) = (t1,t2,t3) +--type instance AsTup (t1,(t2,(t3,(t4,())))) = (t1,t2,t3,t4) +--type instance AsTup (t1,(t2,(t3,(t4,(t5,()))))) = (t1,t2,t3,t4,t5) +--type instance AsTup (t1,(t2,(t3,(t4,(t5,(t6,())))))) = (t1,t2,t3,t4,t5,t6) +--type instance AsTup (t1,(t2,(t3,(t4,(t5,(t6,(t7,()))))))) = (t1,t2,t3,t4,t5,t6,t7) +--type instance AsTup (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,())))))))) = (t1,t2,t3,t4,t5,t6,t7,t8) +--type instance AsTup (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,(t9,()))))))))) = (t1,t2,t3,t4,t5,t6,t7,t8,t9) + +--type family AsRTup a where +-- AsRTup () = () +-- AsRTup (t1,t2) = (t1,(t2,())) +-- AsRTup (t1,t2,t3) = (t1,(t2,(t3,()))) +-- AsRTup (t1,t2,t3,t4) = (t1,(t2,(t3,(t4,())))) +-- AsRTup (t1,t2,t3,t4,t5) = (t1,(t2,(t3,(t4,(t5,()))))) +-- AsRTup (t1,t2,t3,t4,t5,t6) = (t1,(t2,(t3,(t4,(t5,(t6,())))))) +-- AsRTup (t1,t2,t3,t4,t5,t6,t7) = (t1,(t2,(t3,(t4,(t5,(t6,(t7,()))))))) +-- AsRTup (t1,t2,t3,t4,t5,t6,t7,t8) = (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,())))))))) +-- AsRTup (t1,t2,t3,t4,t5,t6,t7,t8,t9) = (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,(t9,()))))))))) +-- AsRTup a = (a,()) + + +--class a ~ AsRTup (AsTup a) => ToTup a where toTup :: a -> AsTup a +--instance ToTup () where toTup _ = () +--instance AsRTup t1 ~ (t1,()) => ToTup (t1,()) where toTup (t1,()) = t1 +--instance ToTup (t1,(t2,())) where toTup (t1,(t2,())) = (t1,t2) +--instance ToTup (t1,(t2,(t3,()))) where toTup (t1,(t2,(t3,()))) = (t1,t2,t3) +--instance ToTup (t1,(t2,(t3,(t4,())))) where toTup (t1,(t2,(t3,(t4,())))) = (t1,t2,t3,t4) +--instance ToTup (t1,(t2,(t3,(t4,(t5,()))))) where toTup (t1,(t2,(t3,(t4,(t5,()))))) = (t1,t2,t3,t4,t5) +--instance ToTup (t1,(t2,(t3,(t4,(t5,(t6,())))))) where toTup (t1,(t2,(t3,(t4,(t5,(t6,())))))) = (t1,t2,t3,t4,t5,t6) +--instance ToTup (t1,(t2,(t3,(t4,(t5,(t6,(t7,()))))))) where toTup (t1,(t2,(t3,(t4,(t5,(t6,(t7,()))))))) = (t1,t2,t3,t4,t5,t6,t7) +--instance ToTup (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,())))))))) where toTup (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,())))))))) = (t1,t2,t3,t4,t5,t6,t7,t8) +--instance ToTup (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,(t9,()))))))))) where toTup (t1,(t2,(t3,(t4,(t5,(t6,(t7,(t8,(t9,()))))))))) = (t1,t2,t3,t4,t5,t6,t7,t8,t9) + +--type SimpleRes a = AsRTup a ~ (a, ()) + + + + + + + + +type Simple (t :: [*] -> [*] -> k) = t '[] '[] diff --git a/src/Data/Container/Proxy.hs b/src/Data/Container/Proxy.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container/Proxy.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + + +-- | This module provides proxy utilities for Data.Container.Class. +-- | The proxy classes allow for nice options-dependent instance implementations, +-- | hiding at the same time the complexity needed for type-level constrains resolution. + +module Data.Container.Proxy where + +import Prelude + +import Data.Container.Class +import Data.Container.Opts (GetQueryData, QueryData, ParamsOf, ModsOf, MatchOpts, Knowledge(..), OptQuery(..), Query(..), getQueryData, Opt) +import Data.Typeable (Proxy(..)) +import GHC.Exts (Constraint) + +----------------------------- +-- === Proxy utilities === -- +----------------------------- + +-- header utils + + +type family ConstrainCls op (ms :: [Opt *]) (ps :: [Opt *]) (info :: * -> Info (Knowledge *) (Knowledge *) *) (m :: * -> *) :: * -> Constraint + +type OpAxioms op info ms t = (ResultAxioms op info ms t, Functor (PrimResult op (GetOpts ms) t)) +type ResultAxioms op info ms t = Result_ op (info t) (GetOpts ms) ~ Result_ op (info (DataStore t)) (GetOpts ms) + +#define OpCtx(cls_, info_) {- Inputs (we need to repeat them, cause OSX cpp preprocessor expands the first occurrence only) -} \ + cls ~ (cls_) \ + , info ~ (info_) \ + {- derives: -} \ + , fullInfo ~ info cont \ + , matchMs ~ MatchOpts (ModsOf cls cont) ms \ + , matchPs ~ MatchOpts (ParamsOf cls cont) ps \ + , provided ~ GetOpts matchMs \ + , opts ~ Result_ cls fullInfo provided \ + , cont ~ Container a \ + , Monad m \ + {- Super-class constraints: -} \ + , ConstrainCls cls_ matchMs matchPs info m cont \ + {- Data queries: -} \ + , QueryData provided ms opts ~ Result_ cls fullInfo ms \ + , GetQueryData provided ms opts \ + {- Query-selected result equality: -} \ + , ResultAxioms cls info matchMs cont \ + {- Type prettify-} \ + , PrettyCtx ms a + + + +------------------------------------- +-- === Proxy operation classes === -- +------------------------------------- + + + +runOp (Proxy :: Proxy cls) (Proxy :: Proxy cont) f getter setter (Query :: Query ms ps) x = do + Res datas c <- f (OptQuery :: OptQuery (MatchOpts (ModsOf cls cont) ms) (MatchOpts (ParamsOf cls cont) ps)) =<< getter x + Res (getQueryData (Proxy :: Proxy (GetOpts (MatchOpts (ModsOf cls cont) ms))) (Proxy :: Proxy ms) datas) <$> setter c x + +#define RUNOP() runOp (Proxy :: Proxy cls) (Proxy :: Proxy cont) + +-- === Finite === + +-- Measurable +-- MinBounded +-- MaxBounded + +class Monad m => MeasurableQM_ ms ps m cont where sizeM_ :: OpAxioms MeasurableOp PrimInfo ms cont => OptQuery ms ps -> cont -> m (PrimResult MeasurableOp (GetOpts ms) cont Int) +class Monad m => MinBoundedQM_ ms ps m idx cont where minBoundM_ :: OpAxioms MinBoundedOp (IdxInfo idx) ms cont => OptQuery ms ps -> cont -> m (IdxResult MinBoundedOp (GetOpts ms) idx cont idx) +class Monad m => MaxBoundedQM_ ms ps m idx cont where maxBoundM_ :: OpAxioms MaxBoundedOp (IdxInfo idx) ms cont => OptQuery ms ps -> cont -> m (IdxResult MaxBoundedOp (GetOpts ms) idx cont idx) + +type instance ConstrainCls MeasurableOp ms ps info m = MeasurableQM_ ms ps m +type instance ConstrainCls MinBoundedOp ms ps ('Info (Known idx) el) m = MinBoundedQM_ ms ps m idx +type instance ConstrainCls MaxBoundedOp ms ps ('Info (Known idx) el) m = MaxBoundedQM_ ms ps m idx + +instance {-# OVERLAPPABLE #-} Monad m => MeasurableQM ImpTL ps m a where sizeQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => MeasurableQM ms ps m Impossible where sizeQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(MeasurableOp,PrimInfo)) => MeasurableQM ms ps m a where sizeQM = RUNOP() sizeM_ viewContainerM (const . return) + +instance {-# OVERLAPPABLE #-} Monad m => MinBoundedQM ImpTL ps m idx a where minBoundQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => MinBoundedQM ms ps m idx Impossible where minBoundQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(MinBoundedOp,IdxInfo idx)) => MinBoundedQM ms ps m idx a where minBoundQM = RUNOP() minBoundM_ viewContainerM (const . return) + +instance {-# OVERLAPPABLE #-} Monad m => MaxBoundedQM ImpTL ps m idx a where maxBoundQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => MaxBoundedQM ms ps m idx Impossible where maxBoundQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(MaxBoundedOp,IdxInfo idx)) => MaxBoundedQM ms ps m idx a where maxBoundQM = RUNOP() maxBoundM_ viewContainerM (const . return) + + +-- === Construction === + +-- Singleton +-- Allocable +-- Expandable +-- Growable + + +class Monad m => SingletonQM_ ms ps m el cont where singletonM_ :: OpAxioms SingletonOp (ElInfo el) ms cont => OptQuery ms ps -> el -> m (ElResult SingletonOp (GetOpts ms) el cont cont) +class Monad m => AllocableQM_ ms ps m cont where allocM_ :: OpAxioms AllocableOp PrimInfo ms cont => OptQuery ms ps -> Int -> m (PrimResult AllocableOp (GetOpts ms) cont cont) +class Monad m => ExpandableQM_ ms ps m cont where expandM_ :: OpAxioms ExpandableOp PrimInfo ms cont => OptQuery ms ps -> cont -> m (PrimResult ExpandableOp (GetOpts ms) cont cont) +class Monad m => GrowableQM_ ms ps m cont where growM_ :: OpAxioms GrowableOp PrimInfo ms cont => OptQuery ms ps -> Int -> cont -> m (PrimResult GrowableOp (GetOpts ms) cont cont) + +type instance ConstrainCls SingletonOp ms ps ('Info idx (Known el)) m = SingletonQM_ ms ps m el +type instance ConstrainCls AllocableOp ms ps info m = AllocableQM_ ms ps m +type instance ConstrainCls ExpandableOp ms ps info m = ExpandableQM_ ms ps m +type instance ConstrainCls GrowableOp ms ps info m = GrowableQM_ ms ps m + +instance {-# OVERLAPPABLE #-} Monad m => SingletonQM ImpTL ps m el a where singletonQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => SingletonQM ms ps m el Impossible where singletonQM = impossible +instance {-# OVERLAPPABLE #-} (IsContainerM m a, OpCtx(SingletonOp,ElInfo el)) => SingletonQM ms ps m el a where singletonQM = RUNOP() singletonM_ return (const . fromContainerM) + +instance {-# OVERLAPPABLE #-} Monad m => AllocableQM ImpTL ps m a where allocQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => AllocableQM ms ps m Impossible where allocQM = impossible +instance {-# OVERLAPPABLE #-} (IsContainerM m a, OpCtx(AllocableOp,PrimInfo) ) => AllocableQM ms ps m a where allocQM = RUNOP() allocM_ return (const . fromContainerM) + +instance {-# OVERLAPPABLE #-} Monad m => ExpandableQM ImpTL ps m a where expandQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => ExpandableQM ms ps m Impossible where expandQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(ExpandableOp,PrimInfo)) => ExpandableQM ms ps m a where expandQM = RUNOP() expandM_ viewContainerM setContainerM + +instance {-# OVERLAPPABLE #-} Monad m => GrowableQM ImpTL ps m a where growQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => GrowableQM ms ps m Impossible where growQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(GrowableOp,PrimInfo) ) => GrowableQM ms ps m a where growQM q i = RUNOP() (flip growM_ i) viewContainerM setContainerM q + + +-- === Modification === +-- Appendable +-- Prependable +-- Addable +-- Removable +-- Insertable +-- Freeable +-- Reservable + + +class Monad m => AppendableQM_ ms ps m el cont where appendM_ :: OpAxioms AppendableOp (ElInfo el) ms cont => OptQuery ms ps -> el -> cont -> m (ElResult AppendableOp (GetOpts ms) el cont cont) +class Monad m => PrependableQM_ ms ps m el cont where prependM_ :: OpAxioms PrependableOp (ElInfo el) ms cont => OptQuery ms ps -> el -> cont -> m (ElResult PrependableOp (GetOpts ms) el cont cont) +class Monad m => AddableQM_ ms ps m el cont where addM_ :: OpAxioms AddableOp (ElInfo el) ms cont => OptQuery ms ps -> el -> cont -> m (ElResult AddableOp (GetOpts ms) el cont cont) +class Monad m => RemovableQM_ ms ps m el cont where removeM_ :: OpAxioms RemovableOp (ElInfo el) ms cont => OptQuery ms ps -> el -> cont -> m (ElResult RemovableOp (GetOpts ms) el cont cont) +class Monad m => InsertableQM_ ms ps m idx el cont where insertM_ :: OpAxioms InsertableOp (IdxElInfo idx el) ms cont => OptQuery ms ps -> idx -> el -> cont -> m (IdxElResult InsertableOp (GetOpts ms) idx el cont cont) +class Monad m => FreeableQM_ ms ps m idx cont where freeM_ :: OpAxioms FreeableOp (IdxInfo idx ) ms cont => OptQuery ms ps -> idx -> cont -> m (IdxResult FreeableOp (GetOpts ms) idx cont cont) +class Monad m => ReservableQM_ ms ps m cont where reserveM_ :: OpAxioms ReservableOp PrimInfo ms cont => OptQuery ms ps -> cont -> m (PrimResult ReservableOp (GetOpts ms) cont cont) + +type instance ConstrainCls AppendableOp ms ps ('Info idx ('Known el)) m = AppendableQM_ ms ps m el +type instance ConstrainCls PrependableOp ms ps ('Info idx ('Known el)) m = PrependableQM_ ms ps m el +type instance ConstrainCls AddableOp ms ps ('Info idx ('Known el)) m = AddableQM_ ms ps m el +type instance ConstrainCls RemovableOp ms ps ('Info idx ('Known el)) m = RemovableQM_ ms ps m el +type instance ConstrainCls InsertableOp ms ps ('Info ('Known idx) ('Known el)) m = InsertableQM_ ms ps m idx el +type instance ConstrainCls FreeableOp ms ps ('Info ('Known idx) el ) m = FreeableQM_ ms ps m idx +type instance ConstrainCls ReservableOp ms ps info m = ReservableQM_ ms ps m + +instance {-# OVERLAPPABLE #-} Monad m => AppendableQM ImpTL ps m el a where appendQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => AppendableQM ms ps m el Impossible where appendQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(AppendableOp,ElInfo el)) => AppendableQM ms ps m el a where appendQM q el = RUNOP() (flip appendM_ el) viewContainerM setContainerM q + +instance {-# OVERLAPPABLE #-} Monad m => PrependableQM ImpTL ps m el a where prependQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => PrependableQM ms ps m el Impossible where prependQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(PrependableOp,ElInfo el)) => PrependableQM ms ps m el a where prependQM q el = RUNOP() (flip prependM_ el) viewContainerM setContainerM q + +instance {-# OVERLAPPABLE #-} Monad m => AddableQM ImpTL ps m el a where addQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => AddableQM ms ps m el Impossible where addQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(AddableOp,ElInfo el)) => AddableQM ms ps m el a where addQM q el = RUNOP() (flip addM_ el) viewContainerM setContainerM q + +instance {-# OVERLAPPABLE #-} Monad m => RemovableQM ImpTL ps m el a where removeQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => RemovableQM ms ps m el Impossible where removeQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(RemovableOp,ElInfo el)) => RemovableQM ms ps m el a where removeQM q el = RUNOP() (flip removeM_ el) viewContainerM setContainerM q + +instance {-# OVERLAPPABLE #-} Monad m => InsertableQM ImpTL ps m idx el a where insertQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => InsertableQM ms ps m idx el Impossible where insertQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(InsertableOp,IdxElInfo idx el)) => InsertableQM ms ps m idx el a where insertQM q idx el = RUNOP() (flip (flip insertM_ idx) el) viewContainerM setContainerM q + +instance {-# OVERLAPPABLE #-} Monad m => FreeableQM ImpTL ps m idx a where freeQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => FreeableQM ms ps m idx Impossible where freeQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(FreeableOp,IdxInfo idx)) => FreeableQM ms ps m idx a where freeQM q idx = RUNOP() (flip freeM_ idx) viewContainerM setContainerM q + +instance {-# OVERLAPPABLE #-} Monad m => ReservableQM ImpTL ps m a where reserveQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => ReservableQM ms ps m Impossible where reserveQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(ReservableOp,PrimInfo)) => ReservableQM ms ps m a where reserveQM q = RUNOP() reserveM_ viewContainerM setContainerM q + + + + +-- === Indexing === + +-- Indexable +-- TracksFreeIxes +-- TracksUsedIxes +-- TracksIxes +-- TracksElems + +class Monad m => IndexableQM_ ms ps m idx el cont where indexM_ :: OpAxioms IndexableOp (IdxElInfo idx el) ms cont => OptQuery ms ps -> idx -> cont -> m (IdxElResult IndexableOp (GetOpts ms) idx el cont el ) +class Monad m => TracksFreeIxesQM_ ms ps m idx cont where freeIxesM_ :: OpAxioms TracksFreeIxesOp (IdxInfo idx ) ms cont => OptQuery ms ps -> cont -> m (IdxResult TracksFreeIxesOp (GetOpts ms) idx cont [idx]) +class Monad m => TracksUsedIxesQM_ ms ps m idx cont where usedIxesM_ :: OpAxioms TracksUsedIxesOp (IdxInfo idx ) ms cont => OptQuery ms ps -> cont -> m (IdxResult TracksUsedIxesOp (GetOpts ms) idx cont [idx]) +class Monad m => TracksIxesQM_ ms ps m idx cont where ixesM_ :: OpAxioms TracksIxesOp (IdxInfo idx ) ms cont => OptQuery ms ps -> cont -> m (IdxResult TracksIxesOp (GetOpts ms) idx cont [idx]) +class Monad m => TracksElemsQM_ ms ps m el cont where elemsM_ :: OpAxioms TracksElemsOp (ElInfo el) ms cont => OptQuery ms ps -> cont -> m (ElResult TracksElemsOp (GetOpts ms) el cont [el] ) + +type instance ConstrainCls IndexableOp ms ps ('Info ('Known idx) ('Known el)) m = IndexableQM_ ms ps m idx el +type instance ConstrainCls TracksFreeIxesOp ms ps ('Info ('Known idx) el ) m = TracksFreeIxesQM_ ms ps m idx +type instance ConstrainCls TracksUsedIxesOp ms ps ('Info ('Known idx) el ) m = TracksUsedIxesQM_ ms ps m idx +type instance ConstrainCls TracksIxesOp ms ps ('Info ('Known idx) el ) m = TracksIxesQM_ ms ps m idx +type instance ConstrainCls TracksElemsOp ms ps ('Info idx ('Known el)) m = TracksElemsQM_ ms ps m el + +instance {-# OVERLAPPABLE #-} Monad m => IndexableQM ImpTL ps m idx el a where indexQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => IndexableQM ms ps m idx el Impossible where indexQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(IndexableOp,IdxElInfo idx el)) => IndexableQM ms ps m idx el a where indexQM q idx = RUNOP() (flip indexM_ idx) viewContainerM (const . return) q + +instance {-# OVERLAPPABLE #-} Monad m => TracksFreeIxesQM ImpTL ps m idx a where freeIxesQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => TracksFreeIxesQM ms ps m idx Impossible where freeIxesQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(TracksFreeIxesOp,IdxInfo idx)) => TracksFreeIxesQM ms ps m idx a where freeIxesQM = RUNOP() freeIxesM_ viewContainerM (const . return) + +instance {-# OVERLAPPABLE #-} Monad m => TracksUsedIxesQM ImpTL ps m idx a where usedIxesQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => TracksUsedIxesQM ms ps m idx Impossible where usedIxesQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(TracksUsedIxesOp,IdxInfo idx)) => TracksUsedIxesQM ms ps m idx a where usedIxesQM = RUNOP() usedIxesM_ viewContainerM (const . return) + +instance {-# OVERLAPPABLE #-} Monad m => TracksIxesQM ImpTL ps m idx a where ixesQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => TracksIxesQM ms ps m idx Impossible where ixesQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(TracksIxesOp,IdxInfo idx)) => TracksIxesQM ms ps m idx a where ixesQM = RUNOP() ixesM_ viewContainerM (const . return) + +instance {-# OVERLAPPABLE #-} Monad m => TracksElemsQM ImpTL ps m el a where elemsQM = impossible +instance {-# OVERLAPPABLE #-} (Monad m, PrettyCtx ms Impossible) => TracksElemsQM ms ps m el Impossible where elemsQM = impossible +instance {-# OVERLAPPABLE #-} (HasContainerM m a, OpCtx(TracksElemsOp,ElInfo el)) => TracksElemsQM ms ps m el a where elemsQM = RUNOP() elemsM_ viewContainerM (const . return) + + + diff --git a/src/Data/Container/Resizable.hs b/src/Data/Container/Resizable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container/Resizable.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveAnyClass #-} + + +module Data.Container.Resizable where + +import Prelude hiding ((.)) + +import Control.Lens +import Control.Monad.Identity +import Data.Container.Class +import Data.Container.List +import Data.Container.Opts (Query(..), ModsOf, ParamsOf) +import qualified Data.Container.Opts as M +import Data.Container.Proxy +import Data.Default +import Data.Layer +import Data.Functor.Utils + +---------------------- +-- === Resizable === -- +---------------------- + +data Resizable style a = Resizable !style !a deriving (Show, Functor, Foldable, Traversable, Monoid) + +type instance Index (Resizable s a) = Index (Container a) +type instance Item (Resizable s a) = Item (Container a) +type instance Container (Resizable s a) = Resizable s a +type instance DataStore (Resizable s a) = Container a + +instance Monad m => IsContainerM m (Resizable s a) where fromContainerM = return +instance Monad m => HasContainerM m (Resizable s a) where viewContainerM = return + setContainerM = const . return + + +type instance Unlayered (Resizable s a) = a +instance Layered (Resizable s a) where layered = lens (\(Resizable _ a) -> a) (\(Resizable s _) a -> Resizable s a) +instance Monad m => LayeredM m (Resizable s a) + +instance (IsContainer a, FromList (Container a), Default s) + => FromList (Resizable s a) where fromList = Resizable def . fromContainer . fromList + +instance (Default s, Default a) => Default (Resizable s a) where def = Resizable def def + +instance (ToList (Container a), HasContainer a) => ToList (Resizable s a) where toList = toList . view container . unlayer + +style :: Lens' (Resizable s a) s +style = lens (\(Resizable s _) -> s) (\(Resizable _ a) s -> Resizable s a) + + + +-- === Styles === + +data Minimal = Minimal deriving (Show) +data Exponential = Exponential deriving (Show) +data Linear = Linear Int deriving (Show) + +instance Default Minimal where def = Minimal +instance Default Exponential where def = Exponential +instance Default Linear where def = Linear 1 + +-- === Resizing utilities ==== + +class ResizeStep s t where resizeStep :: Resizable s t -> Int +instance ResizeStep Minimal t where resizeStep _ = 1 +instance ResizeStep Linear t where resizeStep (view style -> Linear i) = i +instance Measurable (Resizable Exponential t) => ResizeStep Exponential t where resizeStep = checkZeroSize . size +instance Measurable (Resizable Double t) => ResizeStep Double t where resizeStep = (2 *) . checkZeroSize . size + +checkZeroSize :: (Num a, Eq a) => a -> a +checkZeroSize s = if s == 0 then 1 else s + + +------------------------ +-- === Instances === --- +------------------------ + +-- === Finite === + +-- [+] Measurable +-- [+] MinBounded +-- [+] MaxBounded + +type instance ParamsOf MeasurableOp (Resizable s a) = ParamsOf MeasurableOp (Container a) +type instance ModsOf MeasurableOp (Resizable s a) = ModsOf MeasurableOp (Container a) + +type instance ParamsOf MinBoundedOp (Resizable s a) = ParamsOf MinBoundedOp (Container a) +type instance ModsOf MinBoundedOp (Resizable s a) = ModsOf MinBoundedOp (Container a) + +type instance ParamsOf MaxBoundedOp (Resizable s a) = ParamsOf MaxBoundedOp (Container a) +type instance ModsOf MaxBoundedOp (Resizable s a) = ModsOf MaxBoundedOp (Container a) + +instance (MeasurableQM (GetOpts ms) (GetOpts ps) m a) => MeasurableQM_ ms ps m (Resizable s a) where sizeM_ _ = sizeQM (Query :: Query (GetOpts ms) (GetOpts ps)) . unlayer +instance (MinBoundedQM (GetOpts ms) (GetOpts ps) m idx a) => MinBoundedQM_ ms ps m idx (Resizable s a) where minBoundM_ _ = minBoundQM (Query :: Query (GetOpts ms) (GetOpts ps)) . unlayer +instance (MaxBoundedQM (GetOpts ms) (GetOpts ps) m idx a) => MaxBoundedQM_ ms ps m idx (Resizable s a) where maxBoundM_ _ = maxBoundQM (Query :: Query (GetOpts ms) (GetOpts ps)) . unlayer + + + +-- === Construction === + +-- [+] Singleton +-- [+] Allocable +-- [+] Expandable +-- [+] Growable + +type instance ParamsOf SingletonOp (Resizable s a) = ParamsOf SingletonOp (Container a) +type instance ModsOf SingletonOp (Resizable s a) = ModsOf SingletonOp (Container a) + +type instance ParamsOf AllocableOp (Resizable s a) = ParamsOf AllocableOp (Container a) +type instance ModsOf AllocableOp (Resizable s a) = ModsOf AllocableOp (Container a) + +type instance ParamsOf ExpandableOp (Resizable s a) = ParamsOf GrowableOp (Container a) +type instance ModsOf ExpandableOp (Resizable s a) = ModsOf GrowableOp (Container a) + +type instance ParamsOf GrowableOp (Resizable s a) = ParamsOf GrowableOp (Container a) +type instance ModsOf GrowableOp (Resizable s a) = ModsOf GrowableOp (Container a) + +instance (SingletonQM (GetOpts ms) (GetOpts ps) m el a, Default s) => SingletonQM_ ms ps m el (Resizable s a) where singletonM_ _ = fmap2 (Resizable def) . singletonQM (Query :: Query (GetOpts ms) (GetOpts ps)) +instance (AllocableQM (GetOpts ms) (GetOpts ps) m a, Default s) => AllocableQM_ ms ps m (Resizable s a) where allocM_ _ = fmap2 (Resizable def) . allocQM (Query :: Query (GetOpts ms) (GetOpts ps)) +instance ( GrowableQM (GetOpts ms) (GetOpts ps) m a, ResizeStep s a + , Result_ GrowableOp (PrimInfo (Container a)) (GetOpts ms) ~ Result_ ExpandableOp (PrimInfo (Resizable s a)) (GetOpts ms) + ) => ExpandableQM_ ms ps m (Resizable s a) where expandM_ _ t = nested layered (growQM (Query :: Query (GetOpts ms) (GetOpts ps)) $ resizeStep t) t + + + +-- === Modification === +-- [+] Appendable +-- [+] Prependable +-- [+] Addable +-- [+] Removable +-- [+] Insertable +-- [+] Freeable + +type instance ParamsOf AppendableOp (Resizable s a) = ParamsOf AppendableOp (Container a) +type instance ModsOf AppendableOp (Resizable s a) = ModsOf AppendableOp (Container a) + +type instance ParamsOf PrependableOp (Resizable s a) = ParamsOf PrependableOp (Container a) +type instance ModsOf PrependableOp (Resizable s a) = ModsOf PrependableOp (Container a) + +type instance ParamsOf AddableOp (Resizable s a) = ParamsOf AddableOp (Container a) +type instance ModsOf AddableOp (Resizable s a) = ModsOf AddableOp (Container a) + +type instance ParamsOf RemovableOp (Resizable s a) = ParamsOf RemovableOp (Container a) +type instance ModsOf RemovableOp (Resizable s a) = ModsOf RemovableOp (Container a) + +type instance ParamsOf InsertableOp (Resizable s a) = ParamsOf InsertableOp (Container a) +type instance ModsOf InsertableOp (Resizable s a) = ModsOf InsertableOp (Container a) + +type instance ParamsOf FreeableOp (Resizable s a) = ParamsOf FreeableOp (Container a) +type instance ModsOf FreeableOp (Resizable s a) = ModsOf FreeableOp (Container a) + +instance (AppendableQM (GetOpts ms) (GetOpts ps) m el a) => AppendableQM_ ms ps m el (Resizable s 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 (Resizable s a) where prependM_ _ = nested layered . prependQM (Query :: Query (GetOpts ms) (GetOpts ps)) +instance (AddableQM (GetOpts ms) (GetOpts ps) m el a) => AddableQM_ ms ps m el (Resizable s a) where addM_ _ = nested layered . addQM (Query :: Query (GetOpts ms) (GetOpts ps)) +instance (RemovableQM (GetOpts ms) (GetOpts ps) m el a) => RemovableQM_ ms ps m el (Resizable s a) where removeM_ _ = nested layered . removeQM (Query :: Query (GetOpts ms) (GetOpts ps)) +instance (InsertableQM (GetOpts ms) (GetOpts ps) m idx el a) => InsertableQM_ ms ps m idx el (Resizable s a) where insertM_ _ = nested layered .: insertQM (Query :: Query (GetOpts ms) (GetOpts ps)) +instance (FreeableQM (GetOpts ms) (GetOpts ps) m idx a) => FreeableQM_ ms ps m idx (Resizable s a) where freeM_ _ = nested layered . freeQM (Query :: Query (GetOpts ms) (GetOpts ps)) + + + + +---- === Indexing === + +-- [+] Indexable +-- [+] TracksFreeIxes +-- [+] TracksUsedIxes +-- [+] TracksIxes +-- [+] TracksElems + +type instance ParamsOf IndexableOp (Resizable s a) = ParamsOf IndexableOp (Container a) +type instance ModsOf IndexableOp (Resizable s a) = ModsOf IndexableOp (Container a) + +type instance ParamsOf TracksIxesOp (Resizable s a) = ParamsOf TracksIxesOp (Container a) +type instance ModsOf TracksIxesOp (Resizable s a) = ModsOf TracksIxesOp (Container a) + +type instance ParamsOf TracksFreeIxesOp (Resizable s a) = ParamsOf TracksFreeIxesOp (Container a) +type instance ModsOf TracksFreeIxesOp (Resizable s a) = ModsOf TracksFreeIxesOp (Container a) + +type instance ParamsOf TracksUsedIxesOp (Resizable s a) = ParamsOf TracksUsedIxesOp (Container a) +type instance ModsOf TracksUsedIxesOp (Resizable s a) = ModsOf TracksUsedIxesOp (Container a) + +type instance ParamsOf TracksElemsOp (Resizable s a) = ParamsOf TracksElemsOp (Container a) +type instance ModsOf TracksElemsOp (Resizable s a) = ModsOf TracksElemsOp (Container a) + +instance (IndexableQM (GetOpts ms) (GetOpts ps) m idx el a) => IndexableQM_ ms ps m idx el (Resizable s a) where indexM_ _ idx = indexQM (Query :: Query (GetOpts ms) (GetOpts ps)) idx . unlayer +instance (TracksIxesQM (GetOpts ms) (GetOpts ps) m idx a) => TracksIxesQM_ ms ps m idx (Resizable s a) where ixesM_ _ = ixesQM (Query :: Query (GetOpts ms) (GetOpts ps)) . unlayer +instance (TracksFreeIxesQM (GetOpts ms) (GetOpts ps) m idx a) => TracksFreeIxesQM_ ms ps m idx (Resizable s a) where freeIxesM_ _ = freeIxesQM (Query :: Query (GetOpts ms) (GetOpts ps)) . unlayer +instance (TracksUsedIxesQM (GetOpts ms) (GetOpts ps) m idx a) => TracksUsedIxesQM_ ms ps m idx (Resizable s a) where usedIxesM_ _ = usedIxesQM (Query :: Query (GetOpts ms) (GetOpts ps)) . unlayer +instance (TracksElemsQM (GetOpts ms) (GetOpts ps) m el a) => TracksElemsQM_ ms ps m el (Resizable s a) where elemsM_ _ = elemsQM (Query :: Query (GetOpts ms) (GetOpts ps)) . unlayer + + + + + + + + + + + +---- === TF Instances === + +--type instance Container (HResizable l a) = HResizable l a + +--instance IsContainer (HResizable l a) where fromContainer = id +--instance HasContainer (HResizable l a) where container = id + + +--type instance Item (HResizable l a) = Item a +--type instance ElementByIx idx (HResizable l a) = ElementByIx idx a +--type instance Index el (HResizable l a) = Index el a + +--type instance DataStore (HResizable l a) = DataStore a + + +---- === Finite === + +---- [+] Measurable +---- [+] MinBounded +---- [+] MaxBounded + + +--type instance ModsOf MeasurableQSM (HResizable l a) = ModsOf MeasurableQSM a +--type instance ModsOf MinIndexedQSM (HResizable l a) = ModsOf MinIndexedQSM a +--type instance ModsOf MaxIndexedQSM (HResizable l a) = ModsOf MaxIndexedQSM a + +--instance MeasurableQM q m a => MeasurableQSM (HResizable l a) m q s where sizeQSM _ _ = queried (Proxy :: Proxy q) sizeM' . unlayer +--instance MinIndexedQM idx q m a => MinIndexedQSM idx (HResizable l a) m q s where minIndexQSM _ _ = queried (Proxy :: Proxy q) minIndexM' . unlayer +--instance MaxIndexedQM idx q m a => MaxIndexedQSM idx (HResizable l a) m q s where maxIndexQSM _ _ = queried (Proxy :: Proxy q) maxIndexM' . unlayer + + +---- === Construction === + +---- [+] Singleton +---- [+] Allocable +---- [+] Expandable +---- [+] Growable + +-- --type instance ModsOf SingletonQSM (HResizable l a) = ModsOf SingletonQSM a +-- --instance (SingletonQM el q m a, Default l) => SingletonQSM el (HResizable l a) m q s where singletonQSM _ _ = (fmap . fmap) wrap . queried (Proxy :: Proxy q) singletonM' + +-- --type instance ModsOf AllocableQSM (HResizable l a) = ModsOf AllocableQSM a +-- --instance (AllocableQM q m a, Default l) => AllocableQSM (HResizable l a) m q s where allocQSM _ _ = (fmap . fmap) wrap . queried (Proxy :: Proxy q) allocM' + +--type instance ModsOf ExpandableQSM (HResizable l a) = ModsOf GrowableQSM a +--instance (GrowableQM q m a, TransCheck q GrowableInfo ExpandableInfo a, ResizeStep l a) => ExpandableQSM (HResizable l a) m q s where expandQSM _ _ c = nested layered (queried (Proxy :: Proxy q) growM' (resizeStep c)) c + +--type instance ModsOf GrowableQSM (HResizable l a) = ModsOf GrowableQSM a +--instance GrowableQM q m a => GrowableQSM (HResizable l a) m q s where growQSM _ _ = nested layered . queried (Proxy :: Proxy q) growM' + + +---- === Modification === + +---- [+] Appendable +---- [ ] Prependable +---- [ ] Addable +---- [ ] Removable + +--type instance ModsOf AppendableQSM (HResizable l a) = ModsOf AppendableQSM a +--type instance ModsOf InsertableQSM (HResizable l a) = ModsOf InsertableQSM a + +--instance AppendableQM el q m a => AppendableQSM el (HResizable l a) m q s where appendQSM _ _ = nested layered . queried (Proxy :: Proxy q) appendM' +--instance InsertableQM idx el q m a => InsertableQSM idx el (HResizable l a) m q s where insertQSM _ _ = nested layered .: queried (Proxy :: Proxy q) insertM' + + + +------ === Indexing === + +---- [+] Indexable +---- [ ] TracksElems +---- [ ] TracksIxes +---- [ ] TracksFreeIxes +---- [ ] TracksUsedIxes + + +--type instance ModsOf IndexableQSM (HResizable l a) = ModsOf IndexableQSM a +--type instance ModsOf TracksIxesQSM (HResizable l a) = ModsOf TracksIxesQSM a +--type instance ModsOf TracksElemsQSM (HResizable l a) = ModsOf TracksElemsQSM a + +--instance IndexableQM idx el q m a => IndexableQSM idx el (HResizable l a) m q s where indexQSM _ _ idx = queried (Proxy :: Proxy q) indexM' idx . unlayer +--instance TracksIxesQM idx q m a => TracksIxesQSM idx (HResizable l a) m q s where ixesQSM _ _ = queried (Proxy :: Proxy q) ixesM' . unlayer +--instance TracksElemsQM el q m a => TracksElemsQSM el (HResizable l a) m q s where elemsQSM _ _ = queried (Proxy :: Proxy q) elemsM' . unlayer + + + + +-------------------------------------- + + +--data Minimal = Minimal deriving (Show) +--data Exponential = Exponential deriving (Show) + +--instance Default Minimal where def = Minimal +--instance Default Exponential where def = Exponential + +------class Resize2 style cont where +------ resizeAmount :: Proxy style -> cont -> Int + +----class Resize style cont idx where resize :: idx -> HResizable style cont -> HResizable style cont +----instance ( I.MaxIndexed cont idx, I.Growable cont cont, Enum idx, Ord idx) => Resize Minimal cont idx where resize idx c = if isOverBounds idx c then flip I.growQSM c $ ((-) `on` fromEnum) idx $ I.maxIndex c else c +----instance (I.Measurable cont Int, I.MaxIndexed cont idx, I.Growable cont cont, Enum idx, Ord idx) => Resize Exponential cont idx where resize idx c = if isOverBounds idx c then flip I.growQSM c $ dupCheckSize (fromEnum idx) (I.sizeQSM c) - I.sizeQSM c else c + +----class ResizeStep style cont where resizeStep :: HResizable style cont -> Int +----instance ResizeStep Minimal cont where resizeStep c = 1 +----instance I.Measurable cont Int => ResizeStep Exponential cont where resizeStep c = checkZeroSize $ I.sizeQSM c + + + + + +----dupCheckSize i = dupSize i . checkZeroSize + +----dupSize i sizeQSM = if i >= sizeQSM then dupSize i (2 * sizeQSM) +---- else sizeQSM + + +----isOverBounds :: (Ord idx, I.MaxIndexed cont idx, HasContainer t cont) => idx -> t -> Bool +----isOverBounds idx cont = idx > I.maxIndex cont + + + + + + + +---- ---- TODO ---- +---- after doing it we could be able to optimize the premise of ResizeStep Exponential and make inference nicer +---- +---- -- Optimize following use cases: +---- +---- xxx :: (MeasurableQM2 '[] Identity t, (ResultX +---- (Info NA NA MeasurableQSM2 (DataStore t)) +---- (Selected +---- (LstIn (ModsOf MeasurableQSM2 t) '[]) +---- (FilterMutable (ModsOf MeasurableQSM2 t))) +---- ~ ()), +---- +---- DataFillable +---- '[] +---- (TaggedCont +---- (Selected +---- (LstIn (ModsOf MeasurableQSM2 t) '[]) +---- (FilterMutable (ModsOf MeasurableQSM2 t))) +---- ()), (Taggable +---- (Selected +---- (LstIn (ModsOf MeasurableQSM2 t) '[]) +---- (FilterMutable (ModsOf MeasurableQSM2 t))) +---- ())) => HResizable style t -> Int +---- +---- --- in particular: +---- +---- (Selected +---- (LstIn (ModsOf MeasurableQSM2 t) '[]) +---- (FilterMutable (ModsOf MeasurableQSM2 t))) +---- +---- -- should always return [] diff --git a/src/Data/Container/Reusable.hs b/src/Data/Container/Reusable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container/Reusable.hs @@ -0,0 +1,197 @@ +{-# 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 diff --git a/src/Data/Container/Type.hs b/src/Data/Container/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container/Type.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE PolyKinds #-} + +module Data.Container.Type where + +import Prelude + +--type family In (a :: a) (cont :: c) :: Bool + +--type instance In a '[] = False +--type instance In a '[] = False + +type family In a lst where + In a (a ': ls) = True + In a (l ': ls) = In a ls + In a '[] = False diff --git a/src/Data/Container/Weak.hs b/src/Data/Container/Weak.hs new file mode 100644 --- /dev/null +++ b/src/Data/Container/Weak.hs @@ -0,0 +1,388 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FunctionalDependencies #-} + +module Data.Container.Weak where + +import Prelude hiding ((.)) + +import Control.Lens +import Control.Lens.Utils +import Control.Monad +import Control.Monad.Fix +import Control.Monad.IO.Class +import Data.Container.Class +import Data.Container.List +import Data.Container.Proxy +import Data.Default +import Data.Functor.Utils +import Data.Layer + +import Data.Container.Immersed (withDivedM) +import Data.Container.Opts (Query(..), ModsOf, ParamsOf) +import System.IO.Unsafe (unsafePerformIO) + +import qualified Data.Container.Opts as M +import qualified System.Mem.Weak as Mem + +------------------ +-- === Weak === -- +------------------ + +data Weak f a = Weak !(Maybe f) !a deriving (Functor, Foldable, Traversable, Default, Monoid) +type Weak' a = Weak (IdxFinalizer (Index a)) a + +-- Instances + +type instance Index (Weak f a) = Index (Container a) +type instance Item (Weak f a) = WeakData (Item (Container a)) +type instance Container (Weak f a) = Weak f a +type instance DataStore (Weak f a) = Container a +type instance Finalizer (Weak f a) = Maybe f + +instance Monad m => IsContainerM m (Weak f a) where fromContainerM = return +instance Monad m => HasContainerM m (Weak f a) where viewContainerM = return + setContainerM = const . return + +type instance Unlayered (Weak f a) = a +instance Layered (Weak f a) where layered = lens (\(Weak _ a) -> a) (\(Weak f _) a -> Weak f a) + + + +-- === Finalizers === + +newtype IdxFinalizer idx = IdxFinalizer (idx -> IO ()) + +type family Finalizer a +class HasFinalizer a where finalizer :: Lens' a (Finalizer a) + +class HasFinalizerM a m f | a -> f where viewFinalizerM :: a -> m (Maybe f) + setFinalizerM :: Maybe f -> a -> m a + +-- Basic finalizer instances + +instance {-# OVERLAPPABLE #-} ( Finalizer (Unlayered a) ~ Finalizer a + , HasFinalizer (Unlayered a) + , Layered a) + => HasFinalizer a where finalizer = layered . finalizer +instance {-# OVERLAPPABLE #-} HasFinalizer (Weak f a) where finalizer = lens (\(Weak f _) -> f) (\(Weak _ a) f -> Weak f a) + + + + +instance {-# OVERLAPPABLE #-} Monad m => HasFinalizerM (Weak f a) m f where viewFinalizerM (Weak f _) = return f + setFinalizerM f (Weak _ a) = return $ Weak f a + +instance {-# OVERLAPPABLE #-} ( Monad m + , HasFinalizerM (Container (Unlayered a)) m f + , HasContainerM m (Unlayered a) + , LayeredM m a + ) + => HasFinalizerM a m f where viewFinalizerM = viewLayeredM >=> viewContainerM >=> viewFinalizerM + setFinalizerM v a = flip withDivedM a $ setFinalizerM v + + +-- Instances + +instance Rewrapped (IdxFinalizer idx) (IdxFinalizer idx') +instance Wrapped (IdxFinalizer idx) where + type Unwrapped (IdxFinalizer idx) = idx -> IO () + _Wrapped' = iso (\(IdxFinalizer f) -> f) IdxFinalizer + + + +instance Monoid (IdxFinalizer idx) where + mempty = wrap' . const $ return () + mappend (unwrap' -> f) (unwrap' -> f') = wrap' $ \idx -> f idx >> f' idx + +-- items + +type family WeakData a where WeakData (Mem.Weak a) = a +type WeakItemAxiom t = Item (Container t) ~ Mem.Weak (WeakData (Item (Container t))) +instance (WeakItemAxiom a, IsContainer a, FromList (Container a)) => FromList (Weak f a) where + fromList = Weak def . fromContainer . fromList . fmap (unsafePerformIO . flip Mem.mkWeakPtr Nothing) + {-# NOINLINE fromList #-} + + +---- utils + +mkWeakPtr = liftIO .: Mem.mkWeakPtr + +----instance Show (Weak f a) where +---- showsPrec d (Weak f a) = showParen (d > app_prec) $ +---- showString "Weak " . showsPrec (succ app_prec) (fmap (unsafePerformIO . Mem.deRefWeak) c) +---- where app_prec = 10 +---- {-# NOINLINE showsPrec #-} + + +------------------------ +-- === Instances === --- +------------------------ + +-- === Finite === + +-- [+] Measurable +-- [+] MinBounded +-- [+] MaxBounded + +type instance ParamsOf MeasurableOp (Weak f a) = ParamsOf MeasurableOp (Container a) +type instance ModsOf MeasurableOp (Weak f a) = ModsOf MeasurableOp (Container a) + +type instance ParamsOf MinBoundedOp (Weak f a) = ParamsOf MinBoundedOp (Container a) +type instance ModsOf MinBoundedOp (Weak f a) = ModsOf MinBoundedOp (Container a) + +type instance ParamsOf MaxBoundedOp (Weak f a) = ParamsOf MaxBoundedOp (Container a) +type instance ModsOf MaxBoundedOp (Weak f a) = ModsOf MaxBoundedOp (Container a) + +instance (MeasurableQM (GetOpts ms) (GetOpts ps) m a) => MeasurableQM_ ms ps m (Weak f a) where sizeM_ _ = sizeQM (Query :: Query (GetOpts ms) (GetOpts ps)) . unlayer +instance (MinBoundedQM (GetOpts ms) (GetOpts ps) m idx a) => MinBoundedQM_ ms ps m idx (Weak f a) where minBoundM_ _ = minBoundQM (Query :: Query (GetOpts ms) (GetOpts ps)) . unlayer +instance (MaxBoundedQM (GetOpts ms) (GetOpts ps) m idx a) => MaxBoundedQM_ ms ps m idx (Weak f a) where maxBoundM_ _ = maxBoundQM (Query :: Query (GetOpts ms) (GetOpts ps)) . unlayer + + +-- === Construction === + +-- [+] Singleton +-- [+] Allocable +-- [+] Expandable +-- [+] Growable + +type instance ParamsOf SingletonOp (Weak f a) = ParamsOf SingletonOp (Container a) +type instance ModsOf SingletonOp (Weak f a) = ModsOf SingletonOp (Container a) + +type instance ParamsOf AllocableOp (Weak f a) = ParamsOf AllocableOp (Container a) +type instance ModsOf AllocableOp (Weak f a) = ModsOf AllocableOp (Container a) + +type instance ParamsOf ExpandableOp (Weak f a) = ParamsOf GrowableOp (Container a) +type instance ModsOf ExpandableOp (Weak f a) = ModsOf GrowableOp (Container a) + +type instance ParamsOf GrowableOp (Weak f a) = ParamsOf GrowableOp (Container a) +type instance ModsOf GrowableOp (Weak f a) = ModsOf GrowableOp (Container a) + +instance ( MonadIO m + , SingletonQM (GetOpts ms) (GetOpts ps) m (Mem.Weak el) a + , (Result_ SingletonOp (ElInfo (Mem.Weak el) (Container a)) (GetOpts ms) ~ Result_ SingletonOp (ElInfo el (Weak f a)) (GetOpts ms)) + ) => SingletonQM_ ms ps m el (Weak f a) where + singletonM_ _ el = (fmap2 (Weak def) . singletonQM (Query :: Query (GetOpts ms) (GetOpts ps))) =<< (liftIO . flip mkWeakPtr Nothing) el + +instance (AllocableQM (GetOpts ms) (GetOpts ps) m a) => AllocableQM_ ms ps m (Weak f a) where allocM_ _ = fmap2 (Weak def) . allocQM (Query :: Query (GetOpts ms) (GetOpts ps)) +instance (ExpandableQM (GetOpts ms) (GetOpts ps) m a) => ExpandableQM_ ms ps m (Weak f a) where expandM_ _ = nested layered $ expandQM (Query :: Query (GetOpts ms) (GetOpts ps)) +instance (GrowableQM (GetOpts ms) (GetOpts ps) m a) => GrowableQM_ ms ps m (Weak f a) where growM_ _ = nested layered . growQM (Query :: Query (GetOpts ms) (GetOpts ps)) + + + +-- === Modification === +-- [+] Appendable +-- [+] Prependable +-- [+] Addable +-- [ ] Removable +-- [ ] Insertable +-- [+] Freeable + +type instance ParamsOf AppendableOp (Weak f a) = ParamsOf AppendableOp (Container a) +type instance ModsOf AppendableOp (Weak f a) = ModsOf AppendableOp (Container a) + +type instance ParamsOf PrependableOp (Weak f a) = ParamsOf PrependableOp (Container a) +type instance ModsOf PrependableOp (Weak f a) = ModsOf PrependableOp (Container a) + +type instance ParamsOf AddableOp (Weak f a) = ParamsOf AddableOp (Container a) +type instance ModsOf AddableOp (Weak f a) = ModsOf AddableOp (Container a) + +type instance ParamsOf FreeableOp (Weak f a) = ParamsOf FreeableOp (Container a) +type instance ModsOf FreeableOp (Weak f a) = ModsOf FreeableOp (Container a) + + +instance (AppendableQM (M.Ixed ': GetOpts ms) (GetOpts ps) m (Mem.Weak el) a + , Result_ AppendableOp (ElInfo (Mem.Weak el) (Container a)) (GetOpts ms) ~ Result_ AppendableOp (ElInfo el (Weak (IdxFinalizer idx) a)) (GetOpts ms) + , idx ~ Index (Container a) + , MonadIO m + , MonadFix m + ) => AppendableQM_ ms ps m el (Weak (IdxFinalizer idx) a) where + appendM_ _ el t@(Weak mf a) = mdo + Res (ix,ds) r <- appendQM (Query :: Query (M.Ixed ': GetOpts ms) (GetOpts ps)) ref a + ref <- mkWeakPtr el $ fmap (($ ix) . unwrap) mf + return $ Res ds (Weak mf r) + +instance (PrependableQM (M.Ixed ': GetOpts ms) (GetOpts ps) m (Mem.Weak el) a + , Result_ PrependableOp (ElInfo (Mem.Weak el) (Container a)) (GetOpts ms) ~ Result_ PrependableOp (ElInfo el (Weak (IdxFinalizer idx) a)) (GetOpts ms) + , idx ~ Index (Container a) + , MonadIO m + , MonadFix m + ) => PrependableQM_ ms ps m el (Weak (IdxFinalizer idx) a) where + prependM_ _ el t@(Weak mf a) = mdo + Res (ix,ds) r <- prependQM (Query :: Query (M.Ixed ': GetOpts ms) (GetOpts ps)) ref a + ref <- mkWeakPtr el $ fmap (($ ix) . unwrap) mf + return $ Res ds (Weak mf r) + +instance (AddableQM (M.Ixed ': GetOpts ms) (GetOpts ps) m (Mem.Weak el) a + , Result_ AddableOp (ElInfo (Mem.Weak el) (Container a)) (GetOpts ms) ~ Result_ AddableOp (ElInfo el (Weak (IdxFinalizer idx) a)) (GetOpts ms) + , idx ~ Index (Container a) + , MonadIO m + , MonadFix m + ) => AddableQM_ ms ps m el (Weak (IdxFinalizer idx) a) where + addM_ _ el t@(Weak mf a) = mdo + Res (ix,ds) r <- addQM (Query :: Query (M.Ixed ': GetOpts ms) (GetOpts ps)) ref a + ref <- mkWeakPtr el $ fmap (($ ix) . unwrap) mf + return $ Res ds (Weak mf r) + +instance (FreeableQM (GetOpts ms) (GetOpts ps) m idx a, idx ~ idx') => FreeableQM_ ms ps m idx (Weak (IdxFinalizer idx) a) where freeM_ _ = nested layered . freeQM (Query :: Query (GetOpts ms) (GetOpts ps)) + + --flip (nested layered) t $ appendQM (Query :: Query (GetOpts ms) (GetOpts ps)) =<< liftIO (flip Mem.mkWeakPtr f el) +--instance (PrependableQM (GetOpts ms) (GetOpts ps) m el a) => PrependableQM_ ms ps m el (Weak idx a) where prependM_ _ = nested layered . prependQM (Query :: Query (GetOpts ms) (GetOpts ps)) +--instance (InsertableM m idx el a, ExpandableM m (Weak f a)) => AddableQM_ '[] ps m el (Weak idx a) where addM_ q el t = case view indexes t of +-- (x:xs) -> fmap2 (Weak xs) $ insertM' x el $ unlayer t +-- [] -> addM_ q el =<< expandM t +--instance (FreeableQM (GetOpts ms) (GetOpts ps) m idx a, idx ~ idx') => FreeableQM_ ms ps m idx (Weak idx' a) where freeM_ _ idx = fmap2 (indexes %~ (idx:)) . nested layered (freeQM (Query :: Query (GetOpts ms) (GetOpts ps)) idx) + +--instance ( GrowableQM (M.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 (M.Ixed ': GetOpts ms) (GetOpts ps)) i a +-- return $ Res ds $ Reusable (ixs <> ixs') r + + +------------------------ +-- === Instances === --- +------------------------ + +-- === Finite === + +-- [+] Measurable +-- [+] MinBounded +-- [+] MaxBounded + +--type instance ParamsOf MeasurableOp (Weak f a) = ParamsOf MeasurableOp (Container a) +--type instance ModsOf MeasurableOp (Weak f a) = ModsOf MeasurableOp (Container a) + +--type instance ParamsOf MinBoundedOp (Weak f a) = ParamsOf MinBoundedOp (Container a) +--type instance ModsOf MinBoundedOp (Weak f a) = ModsOf MinBoundedOp (Container a) + +--type instance ParamsOf MaxBoundedOp (Weak f a) = ParamsOf MaxBoundedOp (Container a) +--type instance ModsOf MaxBoundedOp (Weak f a) = ModsOf MaxBoundedOp (Container a) + +--instance (MeasurableQM (GetOpts ms) (GetOpts ps) m a) => MeasurableQM_ ms ps m (Weak 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 (Weak 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 (Weak idx' a) where maxBoundM_ _ = maxBoundQM (Query :: Query (GetOpts ms) (GetOpts ps)) . unlayer + + + + +------ === Finite === + +------ [+] Measurable +------ [+] MinBounded +------ [+] MaxBounded + + +--type instance ModsOf MeasurableQSM (Weak c a) = ModsOf MeasurableQSM (WeakData c a) +----type instance ModsOf MinIndexedQSM (Weak c a) = ModsOf MinIndexedQSM a +----type instance ModsOf MaxIndexedQSM (Weak c a) = ModsOf MaxIndexedQSM a + +--instance MeasurableQM q m (WeakData c a) => MeasurableQSM (Weak c a) m q s where sizeQSM _ _ = queried (Proxy :: Proxy q) sizeM' . unlayer +----instance MinIndexedQM q m a => MinIndexedQSM (Weak c a) m q s where minIndexQSM _ _ = queried (Proxy :: Proxy q) minIndexM' . unwrap +----instance MaxIndexedQM q m a => MaxIndexedQSM (Weak c a) m q s where maxIndexQSM _ _ = queried (Proxy :: Proxy q) maxIndexM' . unwrap + +--weaked = lens (\(Weak mf a) -> a) (\(Weak mf _) a -> Weak mf a) + +--nestedWeaked = nested weaked + +------ === Construction === + +------ [+] Singleton +------ [ ] Allocable +------ [+] Expandable +------ [+] Growable + +--type instance ModsOf SingletonQSM (Weak c a) = ModsOf SingletonQSM (WeakData c a) +--type instance ModsOf AllocableQSM (Weak c a) = ModsOf AllocableQSM (WeakData c a) +--type instance ModsOf ExpandableQSM (Weak c a) = ModsOf ExpandableQSM (WeakData c a) +--type instance ModsOf GrowableQSM (Weak c a) = ModsOf GrowableQSM (WeakData c a) + +--instance (MonadIO m, SingletonQM (Mem.Weak el) q m t, t ~ WeakData c a, cls ~ SingletonQSM, +-- EqInfoQueries (SingletonInfo el (DataStore t)) (SingletonInfo (Mem.Weak el) (DataStore t)) (Mods.FilterMutable q) ) => SingletonQSM el (Weak c a) m q s where +-- singletonQSM _ _ el = do +-- ptr <- liftIO $ Mem.mkWeakPtr el Nothing +-- (fmap . fmap) (Weak Nothing) $ queried (Proxy :: Proxy q) singletonM' ptr + +--instance (AllocableQM q m (WeakData c a)) => AllocableQSM (Weak c a) m q s where allocQSM _ _ = (fmap . fmap) (Weak Nothing) . queried (Proxy :: Proxy q) allocM' +--instance (ExpandableQM q m (WeakData c a)) => ExpandableQSM (Weak c a) m q s where expandQSM _ _ = nestedWeaked $ queried (Proxy :: Proxy q) expandM' +--instance (GrowableQM q m (WeakData c a)) => GrowableQSM (Weak c a) m q s where growQSM _ _ = nestedWeaked . queried (Proxy :: Proxy q) growM' + + + +------ === Modification === + +------ [+] Appendable +------ [ ] Prependable +------ [ ] Addable +------ [ ] Removable +------ [+] Insertable + +--type instance ModsOf AppendableQSM (Weak c a) = ModsOf AppendableQSM (WeakData c a) +--type instance ModsOf FreeableQSM (Weak c a) = ModsOf FreeableQSM (WeakData c a) +--type instance ModsOf InsertableQSM (Weak c a) = ModsOf InsertableQSM (WeakData c a) + + +--instance (MonadIO m, MonadFix m, AppendableQM wel (Mods.Ixed ': q) m t +-- , t ~ WeakData c a +-- , wel ~ Mem.Weak el +-- , ds ~ DataStore t +-- , info ~ AppendableInfo wel ds +-- , idx ~ ModData Mods.Ixed info +-- , idx ~ HomoIndex c +-- , EqInfoQueries (AppendableInfo el ds) info (Mods.FilterMutable q) +-- ) => AppendableQSM el (Weak c a) m q s where +-- appendQSM _ _ el (Weak f c) = mdo +-- ptr <- liftIO $ Mem.mkWeakPtr el (($ ixs) <$> f) +-- (ixs, r) <- splitResData <$> nestedWeaked ( (ixed . queried (Proxy :: Proxy q)) appendM' ptr) (Weak f c) +-- return r + +--instance (MonadIO m, MonadFix m, InsertableQM idx wel (Mods.Ixed ': q) m t +-- , t ~ WeakData c a +-- , wel ~ Mem.Weak el +-- , ds ~ DataStore t +-- , info ~ InsertableInfo idx wel ds +-- , idx ~ ModData Mods.Ixed info +-- , idx ~ HomoIndex c +-- , EqInfoQueries (InsertableInfo idx el ds) info (Mods.FilterMutable q) +-- ) => InsertableQSM idx el (Weak c a) m q s where +-- insertQSM _ _ idx el (Weak f c) = mdo +-- ptr <- liftIO $ Mem.mkWeakPtr el (($ ixs) <$> f) +-- (ixs, r) <- splitResData <$> nestedWeaked ( (ixed . queried (Proxy :: Proxy q)) insertM' idx ptr) (Weak f c) +-- return r + +--instance FreeableQM idx q m (WeakData c a) => FreeableQSM idx (Weak c a) m q s where freeQSM _ _ = nestedWeaked . queried (Proxy :: Proxy q) freeM' + + +-------- === Indexing === + +------ [+] Indexable +------ [ ] TracksElems +------ [ ] TracksIxes +------ [+] TracksFreeIxes +------ [ ] TracksUsedIxes + + +----type instance ModsOf IndexableQSM (Weak c a) = ModsOf IndexableQSM a +----type instance ModsOf TracksFreeIxesQSM (Weak c a) = '[] +--type instance ModsOf TracksIxesQSM (Weak c a) = ModsOf TracksIxesQSM (WeakData c a) +--type instance ModsOf TracksElemsQSM (Weak c a) = ModsOf TracksElemsQSM (WeakData c a) + +--instance ( t ~ WeakData c a +-- , ds ~ DataStore t +-- , wel ~ Mem.Weak el +-- , info ~ TracksElemsInfo wel ds +-- , TracksElemsQM (Mem.Weak el) q m (WeakData c a) +-- , EqInfoQueries (TracksElemsInfo el ds) info (Mods.FilterMutable q) +-- ) => TracksElemsQSM el (Weak c a) m q s where elemsQSM _ _ = (fmap . fmap) (catMaybes . fmap (unsafePerformIO . Mem.deRefWeak)) . queried (Proxy :: Proxy q) elemsM' . unlayer + + +--instance TracksIxesQM idx q m (WeakData c a) => TracksIxesQSM idx (Weak c a) m q s where ixesQSM _ _ = queried (Proxy :: Proxy q) ixesM' . unlayer + + +----type instance ModsOf TracksElemsQSM (HWeak l a) = ModsOf TracksElemsQSM a + +----instance IndexableQM idx el q m a => IndexableQSM idx el (HResizable l a) m q s where indexQSM _ _ idx = queried (Proxy :: Proxy q) indexM' idx . unlayer +----instance TracksIxesQM idx q m a => TracksIxesQSM idx (HResizable l a) m q s where ixesQSM _ _ = queried (Proxy :: Proxy q) ixesM' . unlayer diff --git a/src/Data/Item.hs b/src/Data/Item.hs deleted file mode 100644 --- a/src/Data/Item.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Data.Item where - -import Prelude - -import qualified Data.Map as MapLazy -import qualified Data.Map.Strict as MapStrict -import qualified Data.Text as Strict -import qualified Data.Text.Lazy as Lazy - -import Data.Set (Set) - - -type family Item a - -type instance Item [a] = a -type instance Item (MapLazy.Map k v) = (k,v) -type instance Item (MapStrict.Map k v) = (k,v) -type instance Item Strict.Text = Char -type instance Item Lazy.Text = Char -type instance Item (Set a) = a diff --git a/src/Data/List/Class.hs b/src/Data/List/Class.hs deleted file mode 100644 --- a/src/Data/List/Class.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -module Data.List.Class where - -import Data.Item -import Prelude -import Data.Convert -import Control.Lens - -type ToList a = Convertible a [Item a] -type ToList' a = Convertible' a [Item a] -type FromList a = Convertible [Item a] a -type FromList' a = Convertible' [Item a] a -type IsList a = (ToList a, FromList a) -type IsList' a = (ToList' a, FromList' a) - -toList :: ToList a => a -> [Item a] -toList' :: ToList' a => a -> [Item a] -fromList :: FromList a => [Item a] -> a -fromList' :: FromList' a => [Item a] -> a -asList :: IsList a => Iso' a [Item a] -asList' :: IsList' a => Iso' a [Item a] -toList = convert ; {-# INLINE toList #-} -toList' = convert' ; {-# INLINE toList' #-} -fromList = convert ; {-# INLINE fromList #-} -fromList' = convert' ; {-# INLINE fromList' #-} -asList = iso toList fromList ; {-# INLINE asList #-} -asList' = iso toList' fromList' ; {-# INLINE asList' #-} diff --git a/src/Data/Sequence/Class.hs b/src/Data/Sequence/Class.hs deleted file mode 100644 --- a/src/Data/Sequence/Class.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Data.Sequence.Class where - - -import Prelude hiding (dropWhile) - -import Data.Item - -import Data.Char (isSpace) -import qualified Data.List as List -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Lazy as LazyText - - -type LazyText = LazyText.Text - - ----------------------- --- === Sequence === -- ----------------------- - --- === Definition === -- - -class Sequence a where - dropWhile :: (Item a -> Bool) -> a -> a - -class Sequence a => FiniteSequence a where - dropWhileEnd :: (Item a -> Bool) -> a -> a - dropAround :: (Item a -> Bool) -> a -> a - - dropAround f = dropWhileEnd f . dropWhile f - - --- === Utils === -- - -strip, stripStart, stripEnd :: (FiniteSequence a, Item a ~ Char) => a -> a -strip = dropAround isSpace -stripStart = dropWhile isSpace -stripEnd = dropWhileEnd isSpace - - --- === Default instances === -- - -instance Sequence [a] where dropWhile = List.dropWhile -instance FiniteSequence [a] where dropWhileEnd = List.dropWhileEnd - -instance Sequence Text where dropWhile = Text.dropWhile -instance FiniteSequence Text where dropWhileEnd = Text.dropWhileEnd - dropAround = Text.dropAround - -instance Sequence LazyText where dropWhile = LazyText.dropWhile -instance FiniteSequence LazyText where dropWhileEnd = LazyText.dropWhileEnd - dropAround = LazyText.dropAround diff --git a/src/Data/Set/Mutable/Class.hs b/src/Data/Set/Mutable/Class.hs deleted file mode 100644 --- a/src/Data/Set/Mutable/Class.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Data.Set.Mutable.Class - (module Data.Set.Mutable.Class, module X) where - -import Prelude -import Data.Item as X - - -class Monad m => Set m s where - new :: m s - singleton :: Item s -> m s - insert :: s -> Item s -> m () - insertMany :: s -> [Item s] -> m () - delete :: s -> Item s -> m () - member :: s -> Item s -> m Bool - size :: s -> m Int - null :: s -> m Bool - toList :: s -> m [Item s] - fromList :: [Item s] -> m s - - singleton el = do - s <- new - insert s el - pure s - {-# INLINE singleton #-} - - insertMany s es = mapM_ (insert s) es ; {-# INLINE insertMany #-} - - null = fmap (== 0) . size ; {-# INLINE null #-} - - fromList es = do - s <- new - insertMany s es - pure s - {-# INLINE fromList #-}