Re-add Prelude and ExtraT

Both were lost while filtering the repository

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
 

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

src/Data/Observable/Delta.hs

 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

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

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

src/Quasar/Prelude.hs

+{-# 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

src/Quasar/PreludeExtras.hs

+{-# 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)

src/Quasar/Utils/ExtraT.hs

+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

test/Data/Observable/ObservableHashMapSpec.hs

 module Data.Observable.ObservableHashMapSpec where
 
-import Data
+import Data.Observable
 import Data.Observable.Delta
 import qualified Data.Observable.ObservableHashMap as OM