packages feed

logict-sequence 0.2.0.1 → 0.2.0.2

raw patch · 6 files changed

+154/−51 lines, 6 filesdep ~base

Dependency ranges changed: base

Files

CHANGELOG.md view
@@ -1,4 +1,12 @@ # Revision history for logict-sequence+## 0.2.0.2 -- 2022-12-06++* Some of the laziness added in fixing the laziness bug was unnecessary.+  Remove that, allowing scheduled queues to be unboxed once more.+* Improve `RULES`, inlining, etc.+* Work around a [GHC bug](https://gitlab.haskell.org/ghc/ghc/-/issues/22549)+  relating to undecidable instances.+ ## 0.2.0.1 -- 2022-11-23  * Fix a serious laziness bug in `<|>` and `>>=`. These were stricter than they
logict-sequence.cabal view
@@ -1,6 +1,6 @@ cabal-version:      >=1.10 name:               logict-sequence-version:            0.2.0.1+version:            0.2.0.2  -- A short (one-line) description of the package. synopsis:           A backtracking logic-programming monad with asymptotic improvements to msplit
src/Control/Monad/Logic/Sequence/Internal.hs view
@@ -22,6 +22,15 @@  {-# LANGUAGE Trustworthy #-} {-# OPTIONS_HADDOCK not-home #-}+#if __GLASGOW_HASKELL__ >= 902+-- We need this for now to work around+-- https://gitlab.haskell.org/ghc/ghc/-/issues/22549 which otherwise causes+-- infinite loops in several instances. It's definitely needed for GHC 9.4; we+-- do it for 9.2 as well just in case, as others have gotten loops with+-- -fdicts-strict with that version.+{-# OPTIONS_GHC -fno-dicts-strict #-}+#endif+ {- OPTIONS_GHC -ddump-simpl -dsuppress-coercions #-}  -- | Based on the LogicT improvements in the paper, Reflection without@@ -206,7 +215,7 @@  fromViewT :: m (ViewT m a) -> SeqT m a fromViewT = SeqT . S.singleton-{-# INLINE [1] fromViewT #-}+{-# INLINABLE [1] fromViewT #-}  fromView :: forall a. View a -> Seq a fromView = coerce (fromViewT :: Identity (View a) -> Seq a)@@ -314,28 +323,37 @@   (<*>) = ap #endif -  {-# INLINEABLE (*>) #-}-  (toViewT -> m) *> n = fromViewT $ m >>= \x -> case x of-    Empty -> return Empty-    _ :< t -> n `altViewT` (t *> n)+  {-# INLINABLE (*>) #-}+  (toViewT -> m) *> n = fromViewT $ thenViewT m n  #if MIN_VERSION_base(4,10,0)   liftA2 f xs ys = xs >>= \x -> f x <$> ys   {-# INLINABLE liftA2 #-} #endif +thenViewT :: Monad m => m (ViewT m a) -> SeqT m b -> m (ViewT m b)+thenViewT m n = m >>= \x -> case x of+  Empty -> return Empty+  _ :< t -> toViewT n `altViewT` (t *> n)+{-# INLINABLE thenViewT #-}+ instance Monad m => Alternative (SeqT m) where   {-# INLINE empty #-}   {-# INLINEABLE (<|>) #-}   empty = SeqT S.empty-  m <|> n = fromViewT (altViewT m n)+  SeqT m <|> SeqT n = SeqT (m S.>< n) -altViewT :: Monad m => SeqT m a -> SeqT m a -> m (ViewT m a)-altViewT (toViewT -> m) n = m >>= \x -> case x of+-- |+-- @+-- altViewT s t = toViewT (fromViewT s <|> t)+-- @+--+-- Question: is this actually good for optimization?+altViewT :: Monad m => m (ViewT m a) -> SeqT m a -> m (ViewT m a)+altViewT m n = m >>= \x -> case x of   Empty -> toViewT n-  h :< t -> return (h :< cat t n)-    where cat (SeqT l) (SeqT r) = SeqT (l S.>< r)-{-# INLINE altViewT #-}+  h :< t -> return (h :< (t <|> n))+{-# INLINABLE altViewT #-}  -- | @cons a s = pure a <|> s@ cons :: Monad m => a -> SeqT m a -> SeqT m a@@ -349,11 +367,9 @@  instance Monad m => Monad (SeqT m) where   {-# INLINE return #-}-  {-# INLINEABLE (>>=) #-}+  {-# INLINABLE (>>=) #-}   return = pure-  (toViewT -> m) >>= f = fromViewT $ m >>= \x -> case x of-    Empty -> return Empty-    h :< t -> f h `altViewT` (t >>= f)+  (toViewT -> m) >>= f = fromViewT $ bindViewT m f   (>>) = (*>)  #if !MIN_VERSION_base(4,13,0)@@ -361,6 +377,12 @@   fail = Fail.fail #endif +bindViewT :: Monad m => m (ViewT m a) -> (a -> SeqT m b) -> m (ViewT m b)+bindViewT m f = m >>= \x -> case x of+  Empty -> return Empty+  h :< t -> toViewT (f h) `altViewT` (t >>= f)+{-# INLINABLE bindViewT #-}+ instance Monad m => Fail.MonadFail (SeqT m) where   {-# INLINEABLE fail #-}   fail _ = SeqT S.empty@@ -408,7 +430,7 @@    ifte (toViewT -> t) th (toViewT -> el) = fromViewT $ t >>= viewT     el-    (\a s -> altViewT (th a) (s >>= th))+    (\a s -> altViewT (toViewT (th a)) (s >>= th))    once (toViewT -> m) = fromViewT $ m >>= viewT     (return Empty)
src/Control/Monad/Logic/Sequence/Internal/Queue.hs view
@@ -5,8 +5,14 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} #endif-{-# LANGUAGE Safe #-}+{-# LANGUAGE Trustworthy #-} -- for rules +-- | Based on the LogicT improvements in the paper, Reflection without+-- Remorse. Code is based on the code provided in:+-- https://github.com/atzeus/reflectionwithoutremorse+--+-- Note: that code is provided under an MIT license, so we use that as+-- well. module Control.Monad.Logic.Sequence.Internal.Queue (  Queue )@@ -30,41 +36,78 @@ import qualified Data.Foldable as F import qualified Data.Traversable as T import qualified Control.Monad.Logic.Sequence.Internal.ScheduledQueue as SQ-+import Data.Coerce (coerce) --- | Based on the LogicT improvements in the paper, Reflection without--- Remorse. Code is based on the code provided in:--- https://github.com/atzeus/reflectionwithoutremorse+-- | A peculiarly lazy catenable queue. Note that appending multiple+-- 'empty' queues to a non-empty queue can break the amortized constant+-- bound for 'viewl' in the persistent case. ----- Note: that code is provided under an MIT license, so we use that as--- well.-+-- Contextual note: We could actually make these *non-empty* catenable+-- queues, in which case the wonkiness around appending @empty@ would go+-- away. In 'Control.Monad.Logic.Sequence.Internal.SeqT', @SeqT Empty@ is+-- really just an optimized representation of+--+--   @SeqT (singleton (pure Empty))@+--+-- where the @Empty@ in the latter is an empty @ViewT@. data Queue a   = Empty-  | a :< SQ.Queue (Queue a)-  deriving (Functor, F.Foldable, T.Traversable)+  | a :< {-# UNPACK #-} !(SQ.Queue (Queue a))+  deriving (F.Foldable, T.Traversable) +instance Functor Queue where+  fmap f q = mapQueue f q++mapQueue :: (a -> b) -> Queue a -> Queue b+mapQueue _f Empty = Empty+mapQueue f (a :< q) = f a :< fmap (mapQueue f) q+{-# NOINLINE [1] mapQueue #-}++-- These rules aren't (currently) used for SeqT operations, but they're+-- legitimate.+{-# RULES+"fmap/fmap" forall f g q. mapQueue f (mapQueue g q) = mapQueue (f . g) q+"fmap/coerce" mapQueue coerce = coerce+ #-}+ instance Sequence Queue where   {-# INLINE empty #-}   empty = Empty   {-# INLINE singleton #-}   singleton a = a :< S.empty-  {-# INLINE (><) #-}-  Empty >< r = r-  (a :< q) >< r = a :< (q |> r)-  {-# INLINE (|>) #-}+  {-# INLINABLE (><) #-}+  p >< q = p `append` q+  {-# INLINABLE (|>) #-}   l |> x = l >< singleton x-  {-# INLINE (<|) #-}-  x <| r = singleton x >< r+  {-# INLINABLE (<|) #-}+  x <| r = x :< singleton r   {-# INLINE viewl #-}   viewl Empty     = EmptyL-  viewl (t :< q0) = t S.:< linkAll q0-    where-    linkAll :: SQ.Queue (Queue a) -> Queue a-    linkAll v = case viewl v of-      EmptyL -> Empty-      Empty S.:< t' -> linkAll t'-      (x :< q) S.:< t' -> x :< (q |> linkAll t')+  viewl (x :< q0)  = x S.:< linkAll q0++linkAll :: SQ.Queue (Queue a) -> Queue a+linkAll q = case viewl q of+    EmptyL -> Empty+    t S.:< q'  -> linkAll' t q'++linkAll' :: Queue a -> SQ.Queue (Queue a) -> Queue a+linkAll' Empty q' = linkAll q'+linkAll' t@(y :< q) q' = case viewl q' of+  EmptyL -> t+  -- Note: h could potentially be _|_, but that's okay because we don't force+  -- the recursive call.+  h S.:< t' -> y :< (q |> linkAll' h t')++-- I experimented with writing RULES for append, but (short of an explicit+-- staged INLINE) I couldn't do so while getting it to inline into <| when the+-- latter was defined x <| r = singleton x >< r. That made me a bit nervous+-- about other situations it might not inline, so I gave up on those. It's+-- unfortunate, because it seems likely that appends are (slightly) better+-- associated to the left or to the right (I haven't checked which), and it+-- would be nice to reassociate them whichever way is better.+append :: Queue a -> Queue a -> Queue a+append Empty r = r+append (a :< q) r = a :< (q |> r)  #if MIN_VERSION_base(4,9,0) instance Semigroup (Queue a) where
src/Control/Monad/Logic/Sequence/Internal/ScheduledQueue.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ExistentialQuantification #-} + ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Logic.Sequence.Internal.ScheduledQueue@@ -21,7 +21,8 @@ -----------------------------------------------------------------------------  module Control.Monad.Logic.Sequence.Internal.ScheduledQueue-  (Queue) where+  ( Queue+  ) where import Data.SequenceClass (Sequence, ViewL (..)) import qualified Data.SequenceClass as S import Data.Foldable@@ -53,20 +54,35 @@ rotate (x : f) (r :> y) a = x : rotate f r (y : a) rotate _f _a _r  = error "Invariant |f| = |r| + |a| - 1 broken" --- | A scheduled Banker's Queue, as described by Okasaki.-data Queue a = forall x. RQ ![a] !(SL a) ![x]+-- | A scheduled banker's queue, as described by Okasaki. In theory, we only+-- need a queue supporting constant /amortized/ time operations. In practice,+-- once a queue gets large, linear-time pauses and cache effects relating to+-- rebuilding start to hurt.+data Queue a =+  RQ ![a]    -- front (f)+     !(SL a) -- rear (r)+     ![a]  -- schedule (a) -- Invariant: |f| = |r| + |a|--instance Functor Queue where-  fmap f (RQ x y s) = RQ (fmap f x) (fmap f y) s-  a <$ RQ x y s = RQ (a <$ x) (a <$ y) s+  deriving Functor+  -- We would much rather write+  --+  --   data Queue a = forall x. RQ ![a] !(SL a) ![x]+  --+  -- to guarantee we don't accidentally look at elements in the schedule.+  -- Unfortuately, GHC can't currently unpack types with existentials, and+  -- we want to unpack into the catenable queue constructor. We used to use+  -- [Any], but the modern unsafeCoerce makes that produce rather messy core,+  -- and I'm a bit concerned about the term sizes for inlining and such. -queue :: [a] -> SL a -> [x] -> Queue a+queue :: [a] -> SL a -> [a] -> Queue a -- precondition : |f| = |r| + |a| - 1 -- postcondition: |f| = |r| + |a| queue f r [] =   let     f' = appendSL f r+    -- We NOINLINE f' to make sure that walking the schedule actually forces+    -- the front of the queue. GHC probably won't duplicate appendSL anyway,+    -- but let's be sure.     {-# NOINLINE f' #-}   in RQ f' SNil f' queue f r (_h : t) = RQ f r t@@ -76,8 +92,10 @@   singleton x =     let       c = [x]-      {-# NOINLINE c #-}     in RQ c SNil c+  -- The special case for [] gives us better optimizations+  -- for singleton catenable queues.+  RQ [] _ _ |> x = S.singleton x   RQ f r a |> x = queue f (r :> x) a    viewl (RQ [] _SNil _nil) = EmptyL@@ -94,7 +112,18 @@       go q !b = case S.viewl q of         EmptyL -> b         h :< t -> go t (f b h)+#if MIN_VERSION_base(4,8,0)+  null (RQ [] _SNil _nil) = True+  null _ = False +  -- Invariant: |f| = |r| + |a|. The length of the queue is+  -- |f| + |r|+  -- We can calculate that as either 2 * |r| + |a|+  -- or 2 * |f| - a. I suspect the latter will give better+  -- cache utilization.+  length (RQ f _ a) = 2 * length f - length a+#endif+ instance T.Traversable Queue where   traverse f = fmap fromList . go     where@@ -103,4 +132,4 @@         h :< t -> A.liftA2 (:) (f h) (go t)  fromList :: [a] -> Queue a-fromList = foldl' (S.|>) S.empty+fromList f = RQ f SNil f
test/Test.hs view
@@ -1,3 +1,4 @@+{-# language CPP #-} {-# language ScopedTypeVariables #-} {-# language DeriveGeneric #-} {-# language FlexibleContexts #-}