diff --git a/quasar.cabal b/quasar.cabal index 76a3a119dbb32c324955f496bf32fa8eb3cc3d37..f8b4bcbec295aa23f74892d335a1f7b8755cf2b1 100644 --- a/quasar.cabal +++ b/quasar.cabal @@ -65,6 +65,9 @@ library Data.Observable.Delta Data.Observable.ObservableHashMap Data.Observable.ObservablePriority + Quasar.Prelude + Quasar.PreludeExtras + Quasar.Utils.ExtraT hs-source-dirs: src diff --git a/src/Data/Observable.hs b/src/Data/Observable.hs index 9c8a5ae024b1b75b10ad7809c4a226b879aff44a..da5b839d2293b33760f18e346141e047c31686c0 100644 --- a/src/Data/Observable.hs +++ b/src/Data/Observable.hs @@ -31,8 +31,6 @@ module Data.Observable ( waitFor', ) where -import Prelude - import Control.Concurrent.MVar import Control.Exception (Exception) import Control.Monad.Except @@ -41,6 +39,7 @@ import Data.Binary (Binary) import qualified Data.HashMap.Strict as HM import Data.IORef import Data.Unique +import Quasar.Prelude waitFor :: forall a. ((a -> IO ()) -> IO ()) -> IO a waitFor action = do @@ -134,7 +133,7 @@ instance IsGettable a ((a -> IO ()) -> IO ()) where -- | Variant of `getValue` that throws exceptions instead of returning them. unsafeGetValue :: (Exception e, IsObservable (Either e v) o) => o -> IO v -unsafeGetValue = either throw return <=< getValue +unsafeGetValue = either throwIO return <=< getValue -- | A variant of `subscribe` that passes the `Disposable` to the callback. subscribe' :: IsObservable v o => o -> (Disposable -> ObservableMessage v -> IO ()) -> IO Disposable @@ -290,7 +289,7 @@ instance forall o0 v0 o1 v1 r. (IsObservable v0 o0, IsObservable v1 o1) => IsObs where mergeCallback :: IORef (Maybe v0, Maybe v1) -> (MessageReason, Either v0 v1) -> IO () mergeCallback currentValuesTupleRef (reason, state) = do - currentTuple <- atomicModifyIORef' currentValuesTupleRef (dup . updateTuple state) + currentTuple <- atomicModifyIORef' currentValuesTupleRef ((\x -> (x, x)) . updateTuple state) case currentTuple of (Just l, Just r) -> callback (reason, uncurry merge (l, r)) _ -> return () -- Start only once both values have been received diff --git a/src/Data/Observable/Delta.hs b/src/Data/Observable/Delta.hs index 60503634839d18d1630c3c304dc047ca4ea54fe7..6ec8d81c11ee81ffa4b918f33570422b5d34974a 100644 --- a/src/Data/Observable/Delta.hs +++ b/src/Data/Observable/Delta.hs @@ -1,7 +1,7 @@ module Data.Observable.Delta where import Data.Observable -import Prelude +import Quasar.Prelude --import Conduit import qualified Data.HashMap.Strict as HM @@ -39,7 +39,7 @@ observeHashMapDefaultImpl o callback = do subscribeDelta o (deltaCallback hashMapRef) where deltaCallback :: IORef (HM.HashMap k v) -> Delta k v -> IO () - deltaCallback hashMapRef delta = callback =<< atomicModifyIORef' hashMapRef (dup . (applyDelta delta)) + deltaCallback hashMapRef delta = callback =<< atomicModifyIORef' hashMapRef ((\x -> (x, x)) . (applyDelta delta)) applyDelta :: Delta k v -> HM.HashMap k v -> HM.HashMap k v applyDelta (Reset state) = const state applyDelta (Insert key value) = HM.insert key value @@ -59,7 +59,7 @@ instance Functor (DeltaObservable k) where data MappedDeltaObservable k b = forall a o. IsDeltaObservable k a o => MappedDeltaObservable (a -> b) o instance IsGettable (HM.HashMap k b) (MappedDeltaObservable k b) where - getValue (MappedDeltaObservable f o) = f <$$> getValue o + getValue (MappedDeltaObservable f o) = fmap f <$> getValue o instance IsObservable (HM.HashMap k b) (MappedDeltaObservable k b) where subscribe (MappedDeltaObservable f o) callback = subscribe o (callback . fmap (fmap f)) instance IsDeltaObservable k b (MappedDeltaObservable k b) where diff --git a/src/Data/Observable/ObservableHashMap.hs b/src/Data/Observable/ObservableHashMap.hs index 0ddf81579ed42c33bcd28606dada603ecb22f661..d416fad0b9083f7d136ca0c373004c99ed28848f 100644 --- a/src/Data/Observable/ObservableHashMap.hs +++ b/src/Data/Observable/ObservableHashMap.hs @@ -12,8 +12,8 @@ module Data.Observable.ObservableHashMap ( import Data.Observable import Data.Observable.Delta -import Prelude hiding (lookup, lookupDelete) -import Data.Utils.ExtraT +import Quasar.Prelude hiding (lookup, lookupDelete) +import Quasar.Utils.ExtraT import Control.Concurrent.MVar import qualified Data.HashMap.Strict as HM diff --git a/src/Data/Observable/ObservablePriority.hs b/src/Data/Observable/ObservablePriority.hs index aa8f6ffa19e5f79a476aff97a79e7ce7a64c69d1..22768d628d9377d4d9951c1820eab145f2d2813a 100644 --- a/src/Data/Observable/ObservablePriority.hs +++ b/src/Data/Observable/ObservablePriority.hs @@ -5,7 +5,7 @@ module Data.Observable.ObservablePriority ( ) where import Data.Observable -import Prelude +import Quasar.Prelude import Control.Concurrent.MVar import qualified Data.HashMap.Strict as HM diff --git a/src/Quasar/Prelude.hs b/src/Quasar/Prelude.hs new file mode 100644 index 0000000000000000000000000000000000000000..9328989faec10363803b4d679567a6a3a0c74bea --- /dev/null +++ b/src/Quasar/Prelude.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} + +module Quasar.Prelude + ( module BasePrelude, + module Quasar.PreludeExtras, + (>=>), + (<=<), + Control.Applicative.liftA2, + Control.Exception.throwIO, + Control.Monad.forever, + Control.Monad.unless, + Control.Monad.void, + Control.Monad.when, + Control.Monad.forM, + Control.Monad.forM_, + Control.Monad.join, + Data.Void.Void, + Hashable.Hashable, + GHC.Generics.Generic, + MonadIO, + liftIO, + Maybe.catMaybes, + Maybe.fromMaybe, + Maybe.listToMaybe, + Maybe.maybeToList, + error, + errorWithoutStackTrace, + head, + last, + read, + trace, + traceId, + traceShow, + traceShowId, + traceM, + traceShowM, + traceIO, + traceShowIO, + traceShowIdIO, + undefined, + ) +where + +import "base" Prelude as BasePrelude hiding + ( error, + errorWithoutStackTrace, + head, + last, + read, + undefined, + ) +import qualified "base" Prelude as P + +import Quasar.PreludeExtras + +import qualified Control.Applicative +import qualified Control.Exception +import qualified Control.Monad +import qualified Data.Void +import Control.Monad ((>=>), (<=<)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Data.Hashable as Hashable +import qualified Data.Maybe as Maybe +import qualified Debug.Trace as Trace +import qualified GHC.Generics +import qualified GHC.Stack.Types +import qualified GHC.Types + +{-# DEPRECATED head "Partial Function." #-} +head :: [a] -> a +head = P.head + +{-# DEPRECATED last "Partial Function." #-} +last :: [a] -> a +last = P.last + +{-# DEPRECATED read "Partial Function." #-} +read :: Read a => String -> a +read = P.read + +{-# DEPRECATED error "Undefined." #-} +error :: forall (r :: GHC.Types.RuntimeRep). forall (a :: GHC.Types.TYPE r). GHC.Stack.Types.HasCallStack => String -> a +error = P.error + +{-# DEPRECATED errorWithoutStackTrace "Undefined." #-} +errorWithoutStackTrace :: String -> a +errorWithoutStackTrace = P.errorWithoutStackTrace + +{-# DEPRECATED undefined "Undefined." #-} +undefined :: forall (r :: GHC.Types.RuntimeRep). forall (a :: GHC.Types.TYPE r). GHC.Stack.Types.HasCallStack => a +undefined = P.undefined + +{-# DEPRECATED trace "Trace." #-} +trace :: String -> a -> a +trace = Trace.trace + +{-# DEPRECATED traceId "Trace." #-} +traceId :: String -> String +traceId = Trace.traceId + +{-# DEPRECATED traceShow "Trace." #-} +traceShow :: Show a => a -> b -> b +traceShow = Trace.traceShow + +{-# DEPRECATED traceShowId "Trace." #-} +traceShowId :: Show a => a -> a +traceShowId = Trace.traceShowId + +{-# DEPRECATED traceM "Trace." #-} +traceM :: Applicative m => String -> m () +traceM = Trace.traceM + +{-# DEPRECATED traceShowM "Trace." #-} +traceShowM :: (Show a, Applicative m) => a -> m () +traceShowM = Trace.traceShowM + +{-# DEPRECATED traceIO "Trace." #-} +traceIO :: Control.Monad.IO.Class.MonadIO m => String -> m () +traceIO = Control.Monad.IO.Class.liftIO . Trace.traceIO + +{-# DEPRECATED traceShowIO "Trace." #-} +traceShowIO :: (Control.Monad.IO.Class.MonadIO m, Show a) => a -> m () +traceShowIO = traceIO . show + +{-# DEPRECATED traceShowIdIO "Trace." #-} +traceShowIdIO :: (Control.Monad.IO.Class.MonadIO m, Show a) => a -> m a +traceShowIdIO a = traceShowIO a >> return a diff --git a/src/Quasar/PreludeExtras.hs b/src/Quasar/PreludeExtras.hs new file mode 100644 index 0000000000000000000000000000000000000000..d2cb51bb708bdff169fa16e9d79c161dceb7f7f7 --- /dev/null +++ b/src/Quasar/PreludeExtras.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PackageImports #-} + +module Quasar.PreludeExtras where + +-- Use prelude from `base` to prevent module import cycle. +import "base" Prelude + +import Quasar.Utils.ExtraT + +import Control.Monad.State.Lazy as State +import qualified Data.Char as Char +import qualified Data.Hashable as Hashable +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import qualified GHC.Stack.Types + +impossibleCodePath :: GHC.Stack.Types.HasCallStack => a +impossibleCodePath = error "Code path marked as impossible was reached" + +impossibleCodePathM :: MonadFail m => m a +impossibleCodePathM = fail "Code path marked as impossible was reached" + +intercalate :: (Foldable f, Monoid a) => a -> f a -> a +intercalate inter = foldr1 (\a b -> a <> inter <> b) + +dropPrefix :: Eq a => [a] -> [a] -> [a] +dropPrefix prefix list = Maybe.fromMaybe list $ List.stripPrefix prefix list + +dropSuffix :: Eq a => [a] -> [a] -> [a] +dropSuffix suffix list = maybe list reverse $ List.stripPrefix (reverse suffix) (reverse list) + +aesonDropPrefix :: String -> String -> String +aesonDropPrefix prefix = decapitalize . dropPrefix prefix + where + decapitalize (x:xs) = Char.toLower x : xs + decapitalize [] = [] + +maybeToEither :: b -> Maybe a -> Either b a +maybeToEither _ (Just x) = Right x +maybeToEither y Nothing = Left y + +rightToMaybe :: Either a b -> Maybe b +rightToMaybe (Left _) = Nothing +rightToMaybe (Right x) = Just x + +leftToMaybe :: Either a b -> Maybe a +leftToMaybe (Left x) = Just x +leftToMaybe (Right _) = Nothing + +duplicates :: forall a. (Eq a, Hashable.Hashable a) => [a] -> [a] +duplicates = HS.toList . duplicates' HS.empty + where + duplicates' :: HS.HashSet a -> [a] -> HS.HashSet a + duplicates' _ [] = HS.empty + duplicates' set (x:xs) + | HS.member x set = HS.insert x otherDuplicates + | otherwise = otherDuplicates + where + otherDuplicates = duplicates' (HS.insert x set) xs + +-- | Lookup and delete a value from a HashMap in one operation +lookupDelete :: forall k v. (Eq k, Hashable.Hashable k) => k -> HM.HashMap k v -> (HM.HashMap k v, Maybe v) +lookupDelete key m = State.runState fn Nothing + where + fn :: State.State (Maybe v) (HM.HashMap k v) + fn = HM.alterF (\c -> State.put c >> return Nothing) key m + +-- | Lookup a value and insert the given value if it is not already a member of the HashMap. +lookupInsert :: forall k v. (Eq k, Hashable.Hashable k) => k -> v -> HM.HashMap k v -> (HM.HashMap k v, v) +lookupInsert key value hm = runExtra $ HM.alterF fn key hm + where + fn :: Maybe v -> Extra v (Maybe v) + fn Nothing = Extra (Just value, value) + fn (Just oldValue) = Extra (Just oldValue, oldValue) + +infixl 4 <<$>> +(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) +(<<$>>) = fmap . fmap + +dup :: a -> (a, a) +dup x = (x, x) diff --git a/src/Quasar/Utils/ExtraT.hs b/src/Quasar/Utils/ExtraT.hs new file mode 100644 index 0000000000000000000000000000000000000000..72806a618dfad2d52912e3785de04eec9c060349 --- /dev/null +++ b/src/Quasar/Utils/ExtraT.hs @@ -0,0 +1,20 @@ +module Quasar.Utils.ExtraT where + +-- Use prelude from `base` to prevent module import cycle. This allows using ExtraT in PreludeExtras. +import Prelude + +import Data.Bifunctor + +newtype ExtraT s m r = ExtraT { + runExtraT :: m (r, s) +} +instance Functor m => Functor (ExtraT s m) where + fmap :: (a -> b) -> ExtraT s m a -> ExtraT s m b + fmap fn = ExtraT . fmap (first fn) . runExtraT + +newtype Extra s r = Extra { + runExtra :: (r, s) +} +instance Functor (Extra s) where + fmap :: (a -> b) -> Extra s a -> Extra s b + fmap fn = Extra . first fn . runExtra diff --git a/test/Data/Observable/ObservableHashMapSpec.hs b/test/Data/Observable/ObservableHashMapSpec.hs index 1fa262af60998884e8bc214c06914dd48c0a2ada..ef8b0031cd188e52aef073f2271ac7808d33eeaa 100644 --- a/test/Data/Observable/ObservableHashMapSpec.hs +++ b/test/Data/Observable/ObservableHashMapSpec.hs @@ -1,6 +1,6 @@ module Data.Observable.ObservableHashMapSpec where -import Data +import Data.Observable import Data.Observable.Delta import qualified Data.Observable.ObservableHashMap as OM