logict-sequence 0.1.0.1 → 0.2
raw patch · 14 files changed
+1623/−181 lines, 14 filesdep +containersdep +gaugedep +hedgehogdep −type-aligneddep ~basedep ~logictdep ~mtlnew-uploader
Dependencies added: containers, gauge, hedgehog, hedgehog-fn, hspec, hspec-hedgehog, list-t, logict-sequence, mmorph, vector-builder
Dependencies removed: type-aligned
Dependency ranges changed: base, logict, mtl, sequence
Files
- CHANGELOG.md +6/−0
- README.md +1/−0
- bench/logic-performance.hs +184/−0
- include/logict-sequence.h +12/−0
- logict-sequence.cabal +66/−7
- src/Control/Monad/Logic/Sequence.hs +31/−174
- src/Control/Monad/Logic/Sequence/Compat.hs +27/−0
- src/Control/Monad/Logic/Sequence/Internal.hs +622/−0
- src/Control/Monad/Logic/Sequence/Internal/Any.hs +28/−0
- src/Control/Monad/Logic/Sequence/Internal/Queue.hs +87/−0
- src/Control/Monad/Logic/Sequence/Internal/ScheduledQueue.hs +107/−0
- src/Control/Monad/Logic/Sequence/Morph.hs +22/−0
- test/Test.hs +426/−0
- test/do-nothing.hs +4/−0
CHANGELOG.md view
@@ -1,4 +1,10 @@ # Revision history for logict-sequence+## 0.2 -- 2022-11-22++* Rename things having to do with views, to enforce a consistent+ naming convention.++* Drop support for GHC versions before 7.8. ## 0.1.0.0 -- 2021-07-19
README.md view
@@ -1,3 +1,4 @@+[](https://github.com/dagit/logict-sequence/actions/workflows/ci.yml) # LogicT-Sequence Provides a variant of the `LogicT` monad that should have
+ bench/logic-performance.hs view
@@ -0,0 +1,184 @@+------------------------------------------------------------------------- +-- | +-- Copyright : (c) 2016-2021 Koji Miyazato, +-- (c) 2021 Jason Dagit +-- License : MIT +-- +-- Port of a benchmark script by its author, originally written for +-- <https://gitlab.com/viercc/ListT> +-- +-- Performance Tests on various MonadLogic implementations. +-- (1) [] +-- (2) Data.Sequence.Seq +-- (3) ListT m +-- (4) LogicT m +-- (5) SeqT m +------------------------------------------------------------------------- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Main(main) where + +import Control.Applicative +import Control.Monad.Trans +import Control.Monad.Identity +import Control.Monad.ST +import qualified Data.Foldable as F +import Data.Monoid (Alt (..)) +import Data.Tree ( Tree(..) ) + +import Control.Monad.Logic (MonadLogic (..)) +import qualified Control.Monad.Logic as Orig +import qualified Control.Monad.Logic.Sequence as L +import Data.Sequence (Seq, ViewL (..)) +import qualified Data.Sequence as Seq +import ListT + +import Gauge.Main +------------------------------------------------------------------------ +-- Orphan instances + +-- make Seq an instance of MonadLogic using viewl +instance MonadLogic Seq where + msplit s = case Seq.viewl s of + EmptyL -> return Nothing + a :< as -> return (Just (a, as)) + +#if !MIN_VERSION_list_t(1,0,5) +instance Monad m => MonadLogic (ListT m) where + msplit = lift . uncons + interleave as bs = ListT $ uncons as >>= \case + Nothing -> uncons bs + Just (a,as') -> pure (Just (a, interleave bs as')) +#endif + +------------------------------------------------------------------------ +-- how to run MonadLogic instances + +-- | [a]. +runList :: [a] -> [a] +runList = id + +-- | ListT. Most basic Backtracking monad. +runListT_I :: ListT Identity a -> [a] +runListT_I = runIdentity . toList + +-- | ListT ST. +runListT_S :: (forall s. ListT (ST s) a) -> [a] +runListT_S ma = runST (toList ma) + +-- | Seq. Asymptotically fast but constants are large. No transformer version. +runContainersSeq :: Seq a -> [a] +runContainersSeq = F.toList + +-- | Logic. Very fast Monad/MonadPlus operation. Slow interleave. +runLogicT_I :: Orig.Logic a -> [a] +runLogicT_I = Orig.observeAll + +runLogicT_S :: (forall s. Orig.LogicT (ST s) a) -> [a] +runLogicT_S ma = runST (Orig.observeAllT ma) + +-- | SeqT from logict-sequence +runLSeqT_I :: L.Seq a -> [a] +runLSeqT_I = L.observeAll + +runLSeqT_S :: (forall s. L.SeqT (ST s) a) -> [a] +runLSeqT_S ma = runST (L.observeAllT ma) + +------------------------------------------------------------------------ +-- Measured codes +heavy_right_assoc :: (MonadLogic m) => Int -> m () +heavy_right_assoc n = heavy >>= guard + where + heavy = foldr (<|>) (return True) (replicate (n-1) (return False)) +{-# INLINE heavy_right_assoc #-} + +heavy_left_assoc :: (MonadLogic m) => Int -> m () +heavy_left_assoc n = heavy >>= guard + where + falses = F.foldl (<|>) empty (replicate n (return False)) + heavy = falses <|> return True +{-# INLINE heavy_left_assoc #-} + +heavy_treelike :: (MonadLogic m) => Int -> m () +heavy_treelike n = go n True >>= guard + where + go k b + | k <= 1 = return b + | otherwise = + let r = k `div` 2 + l = k - r + in go l False <|> go r b +{-# INLINE heavy_treelike #-} + +heavy_interleave :: (MonadLogic m) => Int -> m () +heavy_interleave n = interleave heavy heavy >>= guard + where + m = n `div` 2 + heavy = foldr (<|>) (return True) (replicate (m-1) (return False)) +{-# INLINE heavy_interleave #-} + +heavy_fairbind :: (MonadLogic m) => Int -> m () +heavy_fairbind n = heavy >>= guard + where + m = n `div` 5 + as = [1 .. 5] :: [Int] + heavy = + choose as >>- \k -> + foldr (<|>) (return (k == 5)) (replicate m (return False)) +{-# INLINE heavy_fairbind #-} + +choose :: (Foldable t, Alternative f) => t a -> f a +choose = getAlt . foldMap (Alt . pure) +-- Copied from post by u/dagit on: +-- https://www.reddit.com/r/haskell/comments/onwfr2/logictsequence_logict_empowered_by_reflection/ +makeTree :: Int -> Tree Int +makeTree n = go 0 + where + go k = Node k (go <$> filter (< n) [k * 3 + 1, k * 3 + 2, k * 3 + 3]) + +bfs :: MonadLogic m => Tree a -> m a +bfs t = go (pure t) + where + go q = do + mb <- msplit q + case mb of + Nothing -> empty + Just (m, qs) -> pure (rootLabel m) <|> go (qs <|> choose (subForest m)) +{-# INLINE bfs #-} + +heavy_bfs :: (MonadLogic m) => Int -> m () +heavy_bfs n = bfs (makeTree n) >>= \k -> guard (k == n) +{-# INLINE heavy_bfs #-} + +------------------------------------------------------------------------ +-- Benchmark definition +main :: IO () +main = + defaultMain + [ bgroup "right_assoc" (forEachMonad heavy_right_assoc), + bgroup "left_assoc" (forEachMonad heavy_left_assoc), + bgroup "treelike" (forEachMonad heavy_treelike), + bgroup "interleave" (forEachMonad heavy_interleave), + bgroup "fairbind" (forEachMonad heavy_fairbind), + bgroup "bfs" (forEachMonad heavy_bfs) + ] + +forEachMonad :: (forall m. (MonadLogic m) => Int -> m ()) -> [Benchmark] +forEachMonad targetLogic = + [ bgroup "[]" (forEachSize $ nf (runList . targetLogic)), + bgroup "Seq" (forEachSize $ nf (runContainersSeq . targetLogic)), + bgroup "ListT_I" (forEachSize $ nf (runListT_I . targetLogic)), + bgroup "ListT_S" (forEachSize $ nf (\n -> runListT_S (targetLogic n))), + bgroup "LogicT_I" (forEachSize $ nf (runLogicT_I . targetLogic)), + bgroup "LogicT_S" (forEachSize $ nf (\n -> runLogicT_S (targetLogic n))), + bgroup "L.SeqT_I" (forEachSize $ nf (\n -> runLSeqT_I (targetLogic n))), + bgroup "L.SeqT_S" (forEachSize $ nf (\n -> runLSeqT_S (targetLogic n))) + ] +{-# INLINE forEachMonad #-} + +forEachSize :: (Int -> Benchmarkable) -> [Benchmark] +forEachSize f = + map (\n -> bench (show n) $ f n) [100, 300, 1000, 3000, 10000]
+ include/logict-sequence.h view
@@ -0,0 +1,12 @@+/*+ * Common macros for logict-sequence+ */++#ifndef HASKELL_LOGICT_SEQUENCE_H+#define HASKELL_LOGICT_SEQUENCE_H++#if __GLASGOW_HASKELL__ >= 804+#define USE_PATTERN_SYNONYMS 1+#endif++#endif
logict-sequence.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: logict-sequence-version: 0.1.0.1+version: 0.2 -- A short (one-line) description of the package. synopsis: A backtracking logic-programming monad with asymptotic improvements to msplit@@ -17,7 +17,7 @@ license: MIT license-file: LICENSE author: Jason Dagit-maintainer: Jason dagit <dagitj@gmail.com>+maintainer: Jason Dagit <dagitj@gmail.com> homepage: https://github.com/dagit/logict-sequence build-type: Simple @@ -27,29 +27,88 @@ -- category: extra-source-files: CHANGELOG.md README.md-tested-with: GHC==8.10.4+ include/logict-sequence.h +tested-with: GHC==7.8.4,GHC==7.10.3,GHC==8.0.2,GHC==8.2.2,GHC==8.4.4,GHC==8.6.5,GHC ==8.8.4,GHC==8.10.4,GHC==9.0.2,GHC==9.2.5,GHC==9.4.3++ source-repository head type: git location: https://github.com/dagit/logict-sequence library exposed-modules: Control.Monad.Logic.Sequence+ , Control.Monad.Logic.Sequence.Compat+ , Control.Monad.Logic.Sequence.Morph+ , Control.Monad.Logic.Sequence.Internal+ , Control.Monad.Logic.Sequence.Internal.Queue+ , Control.Monad.Logic.Sequence.Internal.ScheduledQueue+ , Control.Monad.Logic.Sequence.Internal.Any -- Modules included in this library but not exported. -- other-modules: -- LANGUAGE extensions used by modules in this package. -- other-extensions:- build-depends: base >=4.3 && <5+ build-depends: base >=4.5 && <5 build-depends: mtl >=2.0 && <2.3- build-depends: type-aligned >= 0.9.6 && < 0.10 build-depends: sequence >= 0.9.8 && < 0.10- build-depends: logict+ build-depends: logict >= 0.7.1.0 && < 0.8+ build-depends: mmorph+ build-depends: transformers if impl(ghc < 8.0)- build-depends: fail, transformers+ build-depends: fail hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -O2+ include-dirs: include++test-suite logict-test+ if impl(ghc < 8)+ buildable: False+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ default-language: Haskell2010+ main-is: Test.hs+ build-depends: base >=4.7 && < 5+ , logict-sequence+ , hedgehog+ , hspec+ , hspec-hedgehog+ , hedgehog-fn+ , sequence+ , logict+ , transformers+ , mtl+ , mmorph++ -- Try to work around weird CI failure+ if impl(ghc == 8.4.4)+ build-depends: vector-builder == 0.3.7.2+ if impl(ghc == 8.2.2)+ build-depends: vector-builder == 0.3.7.2++test-suite do-nothing+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ default-language: Haskell2010+ main-is: do-nothing.hs+ build-depends: base++benchmark logic-performance+ if impl(ghc < 8.0.2)+ buildable: False+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: logic-performance.hs+ build-depends: base,+ mtl,+ containers,+ list-t,+ logict,+ gauge,+ logict-sequence+ ghc-options: -Wall -O2 -threaded+ default-language: Haskell2010
src/Control/Monad/Logic/Sequence.hs view
@@ -1,190 +1,47 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleInstances #-}+#include "logict-sequence.h" -#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Safe #-}+#ifdef USE_PATTERN_SYNONYMS+{-# LANGUAGE PatternSynonyms #-} #endif +{-# LANGUAGE Safe #-}+ module Control.Monad.Logic.Sequence-( SeqT(..)+(+#ifdef USE_PATTERN_SYNONYMS+ SeqT(MkSeqT, getSeqT)+#else+ SeqT+#endif , Seq- , Queue- , MSeq(..)- , AsUnitLoop(..)+#ifdef USE_PATTERN_SYNONYMS+ , pattern MkSeq+ , getSeq+#endif+ , ViewT(..)+ , View+ , viewT+ , view+ , toViewT+ , toView+ , fromViewT+ , fromView+ , cons+ , consM+ , choose+ , chooseM , observeAllT , observeAll+ , observeManyT+ , observeMany , observeT , observe- , observeMaybeT- , observeMaybe , module Control.Monad , module Control.Monad.Trans ) where -import Control.Applicative import Control.Monad-import qualified Control.Monad.Fail as Fail-import Control.Monad.Identity (Identity(..))-import Control.Monad.Trans (MonadTrans(..))-import Control.Monad.Trans as Trans-import Control.Monad.Logic.Class-import Control.Monad.IO.Class ()-import Data.TASequence.FastCatQueue as TA-import Data.SequenceClass as S--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(..))-#endif--#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup(..))-#endif--import qualified Data.Foldable as F-import qualified Data.Traversable as T----- | 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.--type Queue = MSeq FastTCQueue--data AsUnitLoop a b c where- UL :: !a -> AsUnitLoop a () ()--newtype MSeq s a = MSeq { getMS :: s (AsUnitLoop a) () () }--newtype SeqT m a = SeqT (Queue (m (Maybe (a, SeqT m a))))--type Seq a = SeqT Identity a--instance TASequence s => Sequence (MSeq s) where- empty = MSeq tempty- singleton = MSeq . tsingleton . UL- l >< r = MSeq (getMS l TA.>< getMS r)- l |> x = MSeq (getMS l TA.|> UL x)- x <| r = MSeq (UL x TA.<| getMS r)- viewl s = case tviewl (getMS s) of- TAEmptyL -> EmptyL- UL h TA.:< t -> h S.:< MSeq t- viewr s = case tviewr (getMS s) of- TAEmptyR -> EmptyR- p TA.:> UL l -> MSeq p S.:> l--instance TASequence s => Functor (MSeq s) where- fmap f = go where- go q = case viewl q of- EmptyL -> S.empty- h S.:< t -> f h S.<| go t--instance TASequence s => F.Foldable (MSeq s) where- foldMap f = fm where- fm q = case viewl q of- EmptyL -> mempty- h S.:< t -> f h `mappend` fm t--instance TASequence s => T.Traversable (MSeq s) where- sequenceA q = case viewl q of- EmptyL -> pure S.empty- h S.:< t -> pure (S.<|) <*> h <*> sequenceA t--fromView :: m (Maybe (a, SeqT m a)) -> SeqT m a-fromView = SeqT . singleton--toView :: Monad m => SeqT m a -> m (Maybe (a, SeqT m a))-toView (SeqT s) = case viewl s of- EmptyL -> pure Nothing- h S.:< t -> h >>= \case- Nothing -> toView (SeqT t)- Just (hi, SeqT ti) -> pure (Just (hi, SeqT (ti S.>< t)))--single :: (MonadPlus mp, Monad m) => a -> m (Maybe (a, mp b))-single a = return (Just (a, mzero))--instance Monad m => Functor (SeqT m) where- fmap f xs = xs >>= return . f--instance Monad m => Applicative (SeqT m) where- pure = fromView . single- (<*>) = liftM2 id--instance Monad m => Alternative (SeqT m) where- empty = SeqT (MSeq tempty)- (toView -> m) <|> n = fromView (m >>= \case- Nothing -> toView n- Just (h,t) -> pure (Just (h, cat t n)))- where cat (SeqT l) (SeqT r) = SeqT (l S.>< r)--instance Monad m => Monad (SeqT m) where- return = fromView . single- (toView -> m) >>= f = fromView (m >>= \case- Nothing -> return Nothing- Just (h,t) -> toView (f h `mplus` (t >>= f)))-#if !MIN_VERSION_base(4,13,0)- fail = Fail.fail-#endif--instance Monad m => Fail.MonadFail (SeqT m) where- fail _ = SeqT S.empty--instance Monad m => MonadPlus (SeqT m) where- mzero = Control.Applicative.empty- mplus = (<|>)--#if MIN_VERSION_base(4,9,0)-instance Monad m => Semigroup (SeqT m a) where- (<>) = mplus- sconcat = foldr1 mplus-#endif--instance Monad m => Monoid (SeqT m a) where- mempty = SeqT (MSeq tempty)- mappend = (<|>)- mconcat = F.asum--instance MonadTrans SeqT where- lift m = fromView (m >>= single)--instance Monad m => MonadLogic (SeqT m) where- msplit (toView -> m) = lift m--observeAllT :: Monad m => SeqT m a -> m [a]-observeAllT (toView -> m) = m >>= go where- go (Just (a,t)) = liftM (a:) (observeAllT t)- go _ = return []--#if !MIN_VERSION_base(4,13,0)-observeT :: Monad m => SeqT m a -> m a-#else-observeT :: MonadFail m => SeqT m a -> m a-#endif-observeT (toView -> m) = m >>= go where- go (Just (a, _)) = pure a- go _ = fail "No results."--observe :: Seq a -> a-observe (toView -> m) = case runIdentity m of- Just (a, _) -> a- _ -> error "No results."--observeMaybeT :: Monad m => SeqT m (Maybe a) -> m (Maybe a)-observeMaybeT (toView -> m) = m >>= go where- go (Just (Just a, _)) = pure (Just a)- go _ = pure Nothing--observeMaybe :: Seq (Maybe a) -> Maybe a-observeMaybe = runIdentity . observeMaybeT--observeAll :: Seq a -> [a]-observeAll = runIdentity . observeAllT--instance MonadIO m => MonadIO (SeqT m) where- liftIO = lift . liftIO+import Control.Monad.Trans+import Control.Monad.Logic.Sequence.Internal
+ src/Control/Monad/Logic/Sequence/Compat.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}+module Control.Monad.Logic.Sequence.Compat+ ( fromSeqT+ , toLogicT+ , fromLogicT+ , observeT+ , observe ) where++import Control.Monad.Identity (Identity(..))+import Control.Monad.Logic.Sequence.Internal hiding ( observeT, observe )++#if !MIN_VERSION_base(4,13,0)+observeT :: Monad m => SeqT m a -> m a+#else+observeT :: MonadFail m => SeqT m a -> m a+#endif+observeT (toViewT -> m) = m >>= go where+ go (a :< _) = return a+ go Empty = fail "No results."+{-# INLINE observeT #-}++observe :: Seq a -> a+observe (toViewT -> m) = case runIdentity m of+ a :< _ -> a+ Empty -> error "No results."+{-# INLINE observe #-}
+ src/Control/Monad/Logic/Sequence/Internal.hs view
@@ -0,0 +1,622 @@+{-# LANGUAGE CPP #-}+#include "logict-sequence.h"+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+#endif+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++#ifdef USE_PATTERN_SYNONYMS+{-# LANGUAGE PatternSynonyms #-}+#endif++{-# LANGUAGE Trustworthy #-}+{-# OPTIONS_HADDOCK not-home #-}+{- OPTIONS_GHC -ddump-simpl -dsuppress-coercions #-}++-- | 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+(+#ifdef USE_PATTERN_SYNONYMS+ SeqT(MkSeqT, getSeqT, ..)+#else+ SeqT(..)+#endif+ , Seq+#ifdef USE_PATTERN_SYNONYMS+ , pattern MkSeq+ , getSeq+#endif+ , ViewT(..)+ , View+ , viewT+ , view+ , toViewT+ , toView+ , fromViewT+ , fromView+ , observeAllT+ , observeAll+ , observeManyT+ , observeMany+ , observeT+ , observe+ , fromSeqT+ , hoistPre+ , hoistPost+ , hoistPreUnexposed+ , hoistPostUnexposed+ , toLogicT+ , fromLogicT+ , cons+ , consM+ , choose+ , chooseM+)+where++import Control.Applicative+import Control.Monad hiding (liftM)+#if !MIN_VERSION_base(4,8,0)+import qualified Control.Monad as Monad+#endif+import qualified Control.Monad.Fail as Fail+import Control.Monad.Identity (Identity(..))+import Control.Monad.Trans (MonadTrans(..))+import Control.Monad.Logic.Class+import qualified Control.Monad.Logic as L+import Control.Monad.IO.Class+import Control.Monad.Reader.Class (MonadReader (..))+import Control.Monad.State.Class (MonadState (..))+import Control.Monad.Error.Class (MonadError (..))+import Control.Monad.Morph (MFunctor (..))+import qualified Data.SequenceClass as S+import Control.Monad.Logic.Sequence.Internal.Queue (Queue)+#if MIN_VERSION_base(4,8,0)+import Control.Monad.Zip (MonadZip (..))+#endif+import qualified Text.Read as TR+import Data.Function (on)+#if MIN_VERSION_base(4,9,0)+import Data.Functor.Classes+#endif++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid(..))+#endif++#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (Semigroup(..))+#endif++import qualified Data.Foldable as F+import qualified Data.Traversable as T+import GHC.Generics (Generic)+import Data.Coerce (coerce)++-- | A view of the front end of a 'SeqT'.+data ViewT m a = Empty | a :< SeqT m a+ deriving Generic+infixl 5 :<++type View = ViewT Identity++-- | A catamorphism for 'ViewT's+viewT :: b -> (a -> SeqT m a -> b) -> ViewT m a -> b+viewT n _ Empty = n+viewT _ c (a :< s) = c a s+{-# INLINE viewT #-}++-- | A catamorphism for 'View's. Note that this is just a type-restricted version+-- of 'viewT'.+view :: b -> (a -> Seq a -> b) -> View a -> b+view = viewT+{-# INLINE view #-}++deriving instance (Show a, Show (SeqT m a)) => Show (ViewT m a)+deriving instance (Read a, Read (SeqT m a)) => Read (ViewT m a)+deriving instance (Eq a, Eq (SeqT m a)) => Eq (ViewT m a)+deriving instance (Ord a, Ord (SeqT m a)) => Ord (ViewT m a)+deriving instance Monad m => Functor (ViewT m)+deriving instance (Monad m, F.Foldable m) => F.Foldable (ViewT m)+instance (Monad m, T.Traversable m) => T.Traversable (ViewT m) where+ traverse _ Empty = pure Empty+ traverse f (x :< xs) =+ liftA2 (\y ys -> y :< fromViewT ys) (f x) (T.traverse (T.traverse f) . toViewT $ xs)+-- The derived instance would use+--+-- traverse f (x :< xs) = liftA2 (:<) (f x) (traverse f xs)+--+-- Inlining the inner `traverse` reveals an application of `fmap` which+-- we fuse with `liftA2`, in case `fmap` isn't free.++#if MIN_VERSION_base(4,9,0)+instance (Eq1 m, Monad m) => Eq1 (ViewT m) where+ liftEq _ Empty Empty = True+ liftEq eq (a :< s) (b :< t) = eq a b && liftEq eq s t+ liftEq _ _ _ = False++instance (Ord1 m, Monad m) => Ord1 (ViewT m) where+ liftCompare _ Empty Empty = EQ+ liftCompare _ Empty (_ :< _) = LT+ liftCompare cmp (a :< s) (b :< t) = cmp a b `mappend` liftCompare cmp s t+ liftCompare _ (_ :< _) Empty = GT++instance (Show1 m, Monad m) => Show1 (ViewT m) where+ liftShowsPrec sp sl d val = case val of+ Empty -> ("Empty" ++)+ a :< s -> showParen (d > 5) $+ sp 6 a .+ showString " :< " .+ liftShowsPrec sp sl 6 s+#endif++-- | An asymptotically efficient logic monad transformer. It is generally best to+-- think of this as being defined+--+-- @+-- newtype SeqT m a = 'MkSeqT' { 'getSeqT' :: m ('ViewT' m a) }+-- @+--+-- Using the 'MkSeqT' pattern synonym with 'getSeqT', you can (almost) pretend+-- it's really defined this way! However, the real implementation is different,+-- so as to be more efficient in the face of deeply left-associated `<|>` or+-- `mplus` applications.+newtype SeqT m a = SeqT (Queue (m (ViewT m a)))++#ifdef USE_PATTERN_SYNONYMS+pattern MkSeqT :: Monad m => m (ViewT m a) -> SeqT m a+pattern MkSeqT{getSeqT} <- (toViewT -> getSeqT)+ where+ MkSeqT = fromViewT+{-# COMPLETE MkSeqT #-}++pattern MkSeq :: View a -> Seq a+pattern MkSeq{getSeq} = MkSeqT (Identity getSeq)+{-# COMPLETE MkSeq #-}+#endif++-- | A specialization of 'SeqT' to the 'Identity' monad. You can+-- imagine that this is defined+--+-- @+-- newtype Seq a = MkSeq { getSeq :: ViewT Identity a }+-- @+--+-- Using the 'MkSeq' pattern synonym with 'getSeq', you can pretend it's+-- really defined this way! However, the real implementation is different,+-- so as to be more efficient in the face of deeply left-associated `<|>`+-- or `mplus` applications.+type Seq = SeqT Identity++fromViewT :: m (ViewT m a) -> SeqT m a+fromViewT = SeqT . S.singleton+{-# INLINE [1] fromViewT #-}++fromView :: forall a. View a -> Seq a+fromView = coerce (fromViewT :: Identity (View a) -> Seq a)+{-# INLINE fromView #-}++toViewT :: Monad m => SeqT m a -> m (ViewT m a)+toViewT (SeqT s) = case S.viewl s of+ S.EmptyL -> return Empty+ h S.:< t -> h >>= \x -> case x of+ Empty -> toViewT (SeqT t)+ hi :< SeqT ti -> return (hi :< SeqT (ti S.>< t))+{-# INLINEABLE [1] toViewT #-}++toView :: forall a. Seq a -> View a+toView = coerce (toViewT :: SeqT Identity a -> Identity (ViewT Identity a))+{-# INLINABLE toView #-}++-- For now, we don't assume the monad identity law holds for the underlying+-- monad. We may re-evaluate that later, but it's a bit tricky to document the+-- detailed strictness requirements properly.+--+-- We do, however, assume that `pure /= _|_`, or that `>>=` doesn't `seq` on+-- its second argument, and that we can therefore eta-reduce `\x -> pure x` to+-- just `pure`. It seems quite safe to assume that at least one of these is+-- true, since in real code they're virtually always *both* true.+{-# RULES+"toViewT . fromViewT" forall m. toViewT (fromViewT m) = m >>= return+ #-}++{-+Theorem: toViewT . fromViewT = id++Proof:++toViewT (fromViewT m)+=+toViewT (SeqT (singleton m))+=+case viewl (singleton m) of+ h S.:< t -> h >>= \x -> case x of+ Empty -> toViewT (SeqT t)+ hi :< SeqT ti -> return (hi :< SeqT (ti S.>< t))+=+m >>= \x -> case x of+ Empty -> toViewT (SeqT S.empty)+ hi :< SeqT ti -> return (hi :< SeqT ti)+=+m >>= \x -> case x of+ Empty -> return Empty+ hi :< SeqT ti -> return (hi :< SeqT ti)+= m >>= \x -> return x+= m -- assuming the appropriate identity law holds for the underlying monad.+-}++instance (Show (m (ViewT m a)), Monad m) => Show (SeqT m a) where+ showsPrec d s = showParen (d > app_prec) $+ showString "MkSeqT " . showsPrec (app_prec + 1) (toViewT s)+ where app_prec = 10++instance Read (m (ViewT m a)) => Read (SeqT m a) where+ readPrec = TR.parens $ TR.prec app_prec $ do+ TR.Ident "MkSeqT" <- TR.lexP+ m <- TR.step TR.readPrec+ return (fromViewT m)+ where app_prec = 10+ readListPrec = TR.readListPrecDefault++instance (Eq a, Eq (m (ViewT m a)), Monad m) => Eq (SeqT m a) where+ (==) = (==) `on` toViewT+instance (Ord a, Ord (m (ViewT m a)), Monad m) => Ord (SeqT m a) where+ compare = compare `on` toViewT+++#if MIN_VERSION_base(4,9,0)+instance (Eq1 m, Monad m) => Eq1 (SeqT m) where+ liftEq eq s t = liftEq (liftEq eq) (toViewT s) (toViewT t)++instance (Ord1 m, Monad m) => Ord1 (SeqT m) where+ liftCompare eq s t = liftCompare (liftCompare eq) (toViewT s) (toViewT t)++instance (Show1 m, Monad m) => Show1 (SeqT m) where+ liftShowsPrec sp sl d s = showParen (d > app_prec) $+ showString "MkSeqT " . liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl) (app_prec + 1) (toViewT s)+ where app_prec = 10+#endif++single :: Monad m => a -> m (ViewT m a)+single a = return (a :< mzero)+{-# INLINE single #-}++instance Monad m => Functor (SeqT m) where+ {-# INLINEABLE fmap #-}+ fmap f (SeqT q) = SeqT $ fmap (myliftM (fmap f)) q+ {-# INLINABLE (<$) #-}+ x <$ SeqT q = SeqT $ fmap (myliftM (x <$)) q++instance Monad m => Applicative (SeqT m) where+ {-# INLINE pure #-}+ {-# INLINABLE (<*>) #-}+ pure = fromViewT . single++#if MIN_VERSION_base(4,8,0)+ fs <*> xs = fs >>= \f -> f <$> xs+#else+ (<*>) = ap+#endif++ {-# INLINEABLE (*>) #-}+ (toViewT -> m) *> n = fromViewT $ m >>= \x -> case x of+ Empty -> return Empty+ _ :< t -> n `altViewT` (t *> n)++#if MIN_VERSION_base(4,10,0)+ liftA2 f xs ys = xs >>= \x -> f x <$> ys+ {-# INLINABLE liftA2 #-}+#endif++instance Monad m => Alternative (SeqT m) where+ {-# INLINE empty #-}+ {-# INLINEABLE (<|>) #-}+ empty = SeqT S.empty+ m <|> n = fromViewT (altViewT m n)++altViewT :: Monad m => SeqT m a -> SeqT m a -> m (ViewT m a)+altViewT (toViewT -> 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 #-}++-- | @cons a s = pure a <|> s@+cons :: Monad m => a -> SeqT m a -> SeqT m a+cons a s = fromViewT (return (a :< s))+{-# INLINE cons #-}++-- | @consM m s = lift m <|> s@+consM :: Monad m => m a -> SeqT m a -> SeqT m a+consM m s = fromViewT (myliftM (:< s) m)+{-# INLINE consM #-}++instance Monad m => Monad (SeqT m) where+ {-# INLINE return #-}+ {-# INLINEABLE (>>=) #-}+ return = pure+ (toViewT -> m) >>= f = fromViewT $ m >>= \x -> case x of+ Empty -> return Empty+ h :< t -> f h `altViewT` (t >>= f)+ (>>) = (*>)++#if !MIN_VERSION_base(4,13,0)+ {-# INLINEABLE fail #-}+ fail = Fail.fail+#endif++instance Monad m => Fail.MonadFail (SeqT m) where+ {-# INLINEABLE fail #-}+ fail _ = SeqT S.empty++instance Monad m => MonadPlus (SeqT m) where+ {-# INLINE mzero #-}+ {-# INLINE mplus #-}+ mzero = Control.Applicative.empty+ mplus = (<|>)++#if MIN_VERSION_base(4,9,0)+instance Monad m => Semigroup (SeqT m a) where+ {-# INLINE (<>) #-}+ {-# INLINE sconcat #-}+ (<>) = mplus+ sconcat = F.asum+#endif++instance Monad m => Monoid (SeqT m a) where+ {-# INLINE mempty #-}+ {-# INLINE mconcat #-}+ mempty = SeqT S.empty+ mconcat = F.asum+#if !MIN_VERSION_base(4,11,0)+ {-# INLINE mappend #-}+ mappend = (<|>)+#endif++instance MonadTrans SeqT where+ {-# INLINE lift #-}+ lift m = fromViewT (m >>= single)++instance Monad m => MonadLogic (SeqT m) where+ {-# INLINE msplit #-}+ msplit (toViewT -> m) = fromViewT $ do+ r <- m+ case r of+ Empty -> single Nothing+ a :< t -> single (Just (a, t))++ interleave m1 m2 = fromViewT $ interleaveViewT m1 m2++ (toViewT -> m) >>- f = fromViewT $ m >>= viewT+ (return Empty) (\a m' -> interleaveViewT (f a) (m' >>- f))++ ifte (toViewT -> t) th (toViewT -> el) = fromViewT $ t >>= viewT+ el+ (\a s -> altViewT (th a) (s >>= th))++ once (toViewT -> m) = fromViewT $ m >>= viewT+ (return Empty)+ (\a _ -> single a)++ lnot (toViewT -> m) = fromViewT $ m >>= viewT+ (single ()) (\ _ _ -> return Empty)++-- | A version of 'interleave' that produces a view instead of a+-- 'SeqT'. This lets us avoid @toViewT . fromViewT@ in '>>-'.+interleaveViewT :: Monad m => SeqT m a -> SeqT m a -> m (ViewT m a)+interleaveViewT (toViewT -> m1) m2 = m1 >>= viewT+ (toViewT m2)+ (\a m1' -> return $ a :< interleave m2 m1')++-- | @choose = foldr (\a s -> pure a <|> s) empty@+--+-- @choose :: Monad m => [a] -> SeqT m a@+choose :: (F.Foldable t, Monad m) => t a -> SeqT m a+choose = F.foldr cons empty+{-# INLINABLE choose #-}++-- | @chooseM = foldr (\ma s -> lift ma <|> s) empty@+--+-- @chooseM :: Monad m => [m a] -> SeqT m a@+chooseM :: (F.Foldable t, Monad m) => t (m a) -> SeqT m a+-- The idea here, which I hope is sensible, is to avoid building and+-- restructuring queues unnecessarily. We end up building only *singleton*+-- queues, which should hopefully be pretty cheap.+chooseM = F.foldr consM empty+{-# INLINABLE chooseM #-}++-- | Perform all the actions in a 'SeqT' and gather the results.+observeAllT :: Monad m => SeqT m a -> m [a]+observeAllT (toViewT -> m) = m >>= go where+ go (a :< t) = myliftM (a:) (toViewT t >>= go)+ go _ = return []+{-# INLINEABLE observeAllT #-}++-- | Perform actions in a 'SeqT' until one of them produces a+-- result. Returns 'Nothing' if there are no results.+observeT :: Monad m => SeqT m a -> m (Maybe a)+observeT (toViewT -> m) = m >>= go where+ go (a :< _) = return (Just a)+ go Empty = return Nothing+{-# INLINE observeT #-}++-- | @observeManyT n s@ performs actions in @s@ until it produces+-- @n@ results or terminates. All the gathered results are returned.+observeManyT :: Monad m => Int -> SeqT m a -> m [a]+observeManyT k m = toViewT m >>= go k where+ go n _ | n <= 0 = return []+ go _ Empty = return []+ go n (a :< t) = myliftM (a:) (observeManyT (n-1) t)+{-# INLINEABLE observeManyT #-}++-- | Get the first result in a 'Seq', if there is one.+observe :: Seq a -> Maybe a+observe = runIdentity . observeT+{-# INLINE observe #-}++-- | Get all the results in a 'Seq'.+observeAll :: Seq a -> [a]+observeAll = runIdentity . observeAllT+{-# INLINE observeAll #-}++-- | @observeMany n s@ gets up to @n@ results from a 'Seq'.+observeMany :: Int -> Seq a -> [a]+observeMany n = runIdentity . observeManyT n+{-# INLINE observeMany #-}++-- | Convert @'SeqT' m a@ to @t m a@ when @t@ is some other logic monad+-- transformer.+fromSeqT :: (Monad m, Monad (t m), MonadTrans t, Alternative (t m)) => SeqT m a -> t m a+fromSeqT (toViewT -> m) = lift m >>= \r -> case r of+ Empty -> empty+ a :< s -> pure a <|> fromSeqT s++-- | Convert @'SeqT' m a@ to @'L.LogicT' m a@.+--+-- @ toLogicT = 'fromSeqT' @+toLogicT :: Monad m => SeqT m a -> L.LogicT m a+toLogicT = fromSeqT++fromLogicT :: Monad m => L.LogicT m a -> SeqT m a+fromLogicT (L.LogicT f) = fromViewT $ f (\a v -> return (a :< fromViewT v)) (return Empty)++instance (Monad m, F.Foldable m) => F.Foldable (SeqT m) where+ foldMap f = F.foldMap (F.foldMap f) . toViewT++instance (Monad m, T.Traversable m) => T.Traversable (SeqT m) where+ -- Why is this lawful? It comes down to the fact that toViewT and+ -- fromViewT are inverses, modulo representation and detailed+ -- strictness. They witness a sort of stepwise isomorphism between+ -- SeqT and the obviously traversable+ --+ -- newtype ML m a = ML (m (ViewT m a))+ --+ -- Why can't we just use the derived Traversable instance? It doesn't+ -- respect ==. See https://github.com/dagit/logict-sequence/issues/51#issuecomment-896242724+ -- for an example.+ traverse f = fmap fromViewT . T.traverse (T.traverse f) . toViewT++-- | 'hoist' is 'hoistPre'.+instance MFunctor SeqT where+ -- Note: if `f` is not a monad morphism, then hoist may not respect+ -- (==). That is, it could be that+ --+ -- s == t = True+ --+ -- but+ --+ -- hoist f s == hoist f t = False..+ --+ -- This behavior is permitted by the MFunctor+ -- documentation, and allows us to avoid restructuring+ -- the SeqT.+ hoist f = hoistPre f++-- | This function is the implementation of 'hoist' for 'SeqT'. The passed+-- function is required to be a monad morphism.+hoistPre :: Monad m => (forall x. m x -> n x) -> SeqT m a -> SeqT n a+hoistPre f (SeqT s) = SeqT $ fmap (f . myliftM go) s+ where+ go Empty = Empty+ go (a :< as) = a :< hoistPre f as++-- | A version of `hoist` that uses the `Monad` instance for @n@+-- rather than for @m@. Like @hoist@, the passed function is required+-- to be a monad morphism.+hoistPost :: Monad n => (forall x. m x -> n x) -> SeqT m a -> SeqT n a+hoistPost f (SeqT s) = SeqT $ fmap (myliftM go . f) s+ where+ go Empty = Empty+ go (a :< as) = a :< hoistPost f as++-- | A version of 'hoist' that works for arbitrary functions, rather+-- than just monad morphisms.+hoistPreUnexposed :: forall m n a. Monad m => (forall x. m x -> n x) -> SeqT m a -> SeqT n a+hoistPreUnexposed f (toViewT -> m) = fromViewT $ f (myliftM go m)+ where+ go Empty = Empty+ go (a :< as) = a :< hoistPreUnexposed f as++-- | A version of 'hoistPost' that works for arbitrary functions, rather+-- than just monad morphisms. This should be preferred when the `Monad` instance+-- for `n` is less expensive than that for `m`.+hoistPostUnexposed :: forall m n a. (Monad m, Monad n) => (forall x. m x -> n x) -> SeqT m a -> SeqT n a+hoistPostUnexposed f (toViewT -> m) = fromViewT $ myliftM go (f m)+ where+ go Empty = Empty+ go (a :< as) = a :< hoistPostUnexposed f as++instance MonadIO m => MonadIO (SeqT m) where+ {-# INLINE liftIO #-}+ liftIO = lift . liftIO++instance MonadReader e m => MonadReader e (SeqT m) where+ -- TODO: write more thorough tests for this instance (issue #31)+ ask = lift ask+ local f (SeqT q) = SeqT $ fmap (local f . myliftM go) q+ where+ go Empty = Empty+ go (a :< s) = a :< local f s++instance MonadState s m => MonadState s (SeqT m) where+ get = lift get+ put = lift . put+ state = lift . state++instance MonadError e m => MonadError e (SeqT m) where+ -- TODO: write tests for this instance (issue #31)+ throwError = lift . throwError+ catchError (toViewT -> m) h = fromViewT $ (myliftM go m) `catchError` (toViewT . h)+ where+ go Empty = Empty+ go (a :< s) = a :< catchError s h++#if MIN_VERSION_base(4,8,0)+instance MonadZip m => MonadZip (SeqT m) where+ mzipWith f (toViewT -> m) (toViewT -> n) = fromViewT $+ mzipWith go m n+ where+ go (a :< as) (b :< bs) = f a b :< mzipWith f as bs+ go _ _ = Empty++ munzip (toViewT -> m)+ | (l, r) <- munzip (fmap go m) = (fromViewT l, fromViewT r)+ where+ go Empty = (Empty, Empty)+ go ((a, b) :< asbs) = (a :< as, b :< bs)+ where+ -- We want to be lazy so we don't force the entire+ -- structure unnecessarily. But we don't want to introduce+ -- a space leak, so we're careful to create selector thunks+ -- to deconstruct the rest of the chain.+ {-# NOINLINE muabs #-}+ {-# NOINLINE as #-}+ {-# NOINLINE bs #-}+ muabs = munzip asbs+ (as, bs) = muabs+#endif++#if MIN_VERSION_base(4,8,0)+myliftM :: Functor m => (a -> b) -> m a -> m b+myliftM = fmap+#else+myliftM :: Monad m => (a -> b) -> m a -> m b+myliftM = Monad.liftM+#endif+{-# INLINE myliftM #-}
+ src/Control/Monad/Logic/Sequence/Internal/Any.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-}+-- We suppress this warning because otherwise GHC complains+-- about the newtype constructor not being used.+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+#endif++-- | It's safe to coerce /to/ 'Any' as long as you don't+-- coerce back. We define our own 'Any' instead of using+-- the one in "GHC.Exts" directly to ensure that this+-- module doesn't clash with one making the opposite+-- assumption. We use a newtype rather than a closed type+-- family with no instances because the latter weren't supported+-- until 8.0.+module Control.Monad.Logic.Sequence.Internal.Any+ ( Any+ , toAnyList+ ) where++import Unsafe.Coerce+import qualified GHC.Exts as E++newtype Any = Any E.Any++-- | Convert a list of anything to a list of 'Any'.+toAnyList :: [a] -> [Any]+toAnyList = unsafeCoerce
+ src/Control/Monad/Logic/Sequence/Internal/Queue.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveTraversable #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+#endif+{-# LANGUAGE Safe #-}++module Control.Monad.Logic.Sequence.Internal.Queue+( Queue+)+where++import Data.SequenceClass hiding ((:<))+import qualified Data.SequenceClass as S++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid(..))+#endif++#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup(..))+#endif++import qualified Data.Foldable as F+import qualified Data.Traversable as T+import qualified Control.Monad.Logic.Sequence.Internal.ScheduledQueue as SQ+++-- | 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.++data Queue a+ = Empty+ | a :< {-# UNPACK #-} !(SQ.Queue (Queue a))+ deriving (Functor, F.Foldable, T.Traversable)++instance Sequence Queue where+ {-# INLINE empty #-}+ empty = Empty+ {-# INLINE singleton #-}+ singleton a = a :< S.empty+ {-# INLINE (><) #-}+ Empty >< r = r+ q >< Empty = q+ (a :< q) >< r = a :< (q |> r)+ {-# INLINE (|>) #-}+ l |> x = l >< singleton x+ {-# INLINE (<|) #-}+ x <| r = singleton x >< r+ {-# INLINE viewl #-}+ viewl Empty = EmptyL+ viewl (x :< q0) = x S.:< case viewl q0 of+ EmptyL -> Empty+ t S.:< q' -> linkAll t q'+ where+ linkAll :: Queue a -> SQ.Queue (Queue a) -> Queue a+ linkAll t@(y :< q) q' = case viewl q' of+ EmptyL -> t+ h S.:< t' -> y :< (q |> linkAll h t')+ linkAll Empty _ = error "Invariant failure"+++#if MIN_VERSION_base(4,9,0)+instance Semigroup (Queue a) where+ {-# INLINE (<>) #-}+ (<>) = (S.><)+#endif++instance Monoid (Queue a) where+ {-# INLINE mempty #-}+ mempty = S.empty+ {-# INLINE mappend #-}+#if MIN_VERSION_base(4,9,0)+ mappend = (<>)+#else+ mappend = (S.><)+#endif
+ src/Control/Monad/Logic/Sequence/Internal/ScheduledQueue.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE BangPatterns #-}+++-----------------------------------------------------------------------------+-- |+-- Module : Control.Monad.Logic.Sequence.Internal.ScheduledQueue+-- Copyright : (c) Atze van der Ploeg 2014+-- (c) David Feuer 2021+-- License : BSD-style+-- Maintainer : David.Feuer@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- A sequence, a queue, with worst case constant time: '|>', and 'viewl'.+--+-- Based on: "Simple and Efficient Purely Functional Queues and Deques", Chris Okasaki,+-- Journal of Functional Programming 1995+--+-----------------------------------------------------------------------------++module Control.Monad.Logic.Sequence.Internal.ScheduledQueue+ (Queue) where+import Data.SequenceClass (Sequence, ViewL (..))+import qualified Data.SequenceClass as S+import Data.Foldable+import qualified Data.Traversable as T+import Control.Monad.Logic.Sequence.Internal.Any+import qualified Control.Applicative as A++#if !MIN_VERSION_base(4,8,0)+import Data.Functor (Functor (..))+import Data.Monoid (Monoid (..))+#endif++infixl 5 :>+-- | A strict-spined snoc-list+data SL a+ = SNil+ | !(SL a) :> a+ deriving Functor++-- | Append a snoc list to a list.+--+-- Precondition: |f| = |r| - 1+appendSL :: [a] -> SL a -> [a]+appendSL f r = rotate f r []++-- Precondition:+-- |f| = |r| - 1+rotate :: [a] -> SL a -> [a] -> [a]+rotate [] (~SNil :> y) a = y : a+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 = RQ ![a] !(SL a) ![Any]+-- Invariant: |f| = |r| + |a|+ deriving Functor+ -- We use 'Any' rather than an existential to allow GHC to unpack+ -- queues. In particular, we want to unpack into the catenable queue+ -- constructor.++queue :: [a] -> SL a -> [Any] -> Queue a+-- precondition : |f| = |r| + |a| - 1+-- postcondition: |f| = |r| + |a|+queue f r [] =+ let+ f' = appendSL f r+ {-# NOINLINE f' #-}+ in RQ f' SNil (toAnyList f')+queue f r (_h : t) = RQ f r t++instance Sequence Queue where+ empty = RQ [] SNil []+ singleton x =+ let+ c = [x]+ {-# NOINLINE c #-}+ in RQ c SNil (toAnyList c)+ RQ f r a |> x = queue f (r :> x) a++ viewl (RQ [] ~SNil ~[]) = EmptyL+ viewl (RQ (h : t) f a) = h :< queue t f a++instance Foldable Queue where+ foldr c n = \q -> go q+ where+ go q = case S.viewl q of+ EmptyL -> n+ h :< t -> c h (go t)+ foldl' f b0 = \q -> go q b0+ where+ go q !b = case S.viewl q of+ EmptyL -> b+ h :< t -> go t (f b h)++instance T.Traversable Queue where+ traverse f = fmap fromList . go+ where+ go q = case S.viewl q of+ EmptyL -> A.pure []+ h :< t -> A.liftA2 (:) (f h) (go t)++fromList :: [a] -> Queue a+fromList = foldl' (S.|>) S.empty
+ src/Control/Monad/Logic/Sequence/Morph.hs view
@@ -0,0 +1,22 @@+-- |+-- This module provides functions for changing the underlying+-- monad of a 'SeqT', just like "Control.Monad.Morph".'Control.Monad.Morph.hoist'.+--+-- The functions with the word \"Pre\" in their names lean on the+-- `Monad` instance of the original monad. The ones with the word+-- \"Post\" in their names lean on the `Monad` instance of the+-- target monad. The ones with the word \"Unexposed\" in their names+-- are reasonably well-behaved when the passed function is not+-- a monad morphism (as described in the "Control.Monad.Morph" documentation).+-- The others are typically a little more efficient, but may behave+-- strangely when passed non-monad-morphisms. In particular, if @f@ is+-- not a monad morphism, and @s1 == s2@, we do not even guarantee that+-- @'hoistPre' f s1 == 'hoistPre' f s2@.+module Control.Monad.Logic.Sequence.Morph+ ( hoistPreUnexposed+ , hoistPost+ , hoistPostUnexposed+ , hoistPre+ ) where++import Control.Monad.Logic.Sequence.Internal
+ test/Test.hs view
@@ -0,0 +1,426 @@+{-# language ScopedTypeVariables #-}+{-# language DeriveGeneric #-}+{-# language FlexibleContexts #-}+{-# language UndecidableInstances #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language DeriveTraversable #-}+{-# language StandaloneDeriving #-}+{-# language ViewPatterns #-}+module Main(main) where++import Control.Monad.IO.Class (liftIO)+import Hedgehog (MonadGen, Range)+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen+import Hedgehog.Range (Size)+import qualified Hedgehog.Range as Range+import Test.Hspec (before, describe, hspec, it, shouldBe)+import Test.Hspec.Hedgehog (PropertyT, diff, forAll, hedgehog, (/==), (===))+import Control.Monad.Logic.Class (MonadLogic (..))+import Control.Monad.Logic.Sequence+import qualified Control.Monad.Logic.Sequence.Compat as Compat+import Control.Monad.Logic.Sequence.Internal (SeqT (..))+import Data.SequenceClass hiding ((:<), empty)+import qualified Data.SequenceClass as S+import Control.Monad.Logic.Sequence.Internal.Queue+import Data.Functor.Identity+import Control.Applicative+import Data.Function (fix, on)+import GHC.Generics (Generic)+import qualified Hedgehog.Function as Fun+import Data.Foldable (foldl', for_)+import qualified Control.Monad.Logic as L+import Debug.Trace (trace)+import Control.Monad.Trans.Maybe+import Control.Monad.Reader+import Control.Monad.Except+import Control.Monad.Morph (hoist)+import Control.Monad.ST+import Text.Read (readMaybe)+import Data.List (cycle)++-- | A generic "container" functor. We can use this with `Free` to get+-- an inspectable `Monad` that's unlikely to hide any mistakes we make.+data TestF a = TestF !Int [a]+ deriving (Show, Read, Eq, Generic, Functor, Foldable, Traversable)++instance Fun.Arg a => Fun.Arg (TestF a)+++-- Note: size+--+-- I've found it quite difficult to get a good range of+-- sizes for SeqT TestM Int using the basic tools in+-- Gen. Preventing almost all examples being tiny seems to lead to+-- some examples being unmanageably enormous. So I've decided to+-- go with a "nuclear option". First, I select the approximate total number+-- of nodes in the SeqT. Then at each stage, the approximate total size is+-- chosen in advance to make sure the target is met.++-- | Generate a partition of a non-negative integer into positive+-- integers. This is not statistically fair because I'm not that smart.+splat :: MonadGen m => Size -> m [Size]+splat 0 = pure []+splat n = do+ k <- Gen.integral (Range.constant 1 n)+ rest <- splat (n - k)+ pure (k : rest)++genTestFSized :: MonadGen m => (Size -> m a) -> Size -> m (TestF a)+genTestFSized m sz = do+ i <- Gen.integral (Range.constant 1 10000)+ part <- splat sz+ goop <- traverse m part+ pure (TestF i goop)++newtype TestM a = TestM (Free TestF a)+ deriving (Show, Read, Eq, Generic, Functor, Applicative, Monad, Foldable, Traversable)++genTestMSized :: MonadGen m => (Size -> m a) -> Size -> m (TestM a)+genTestMSized = \m sz -> TestM <$> go m sz+ where+ go :: MonadGen m => (Size -> m a) -> Size -> m (Free TestF a)+ go m n | n <= 1 = Pure <$> m (n - 1)+ go m n = Free <$> genTestFSized (go m) (n - 1)++-- | Generate a test monad value.+genTestM :: MonadGen m => m a -> m (TestM a)+genTestM m = Gen.sized $ \sz -> do+ true_size <- Gen.integral (Range.constant 0 sz)+ genTestMSized (const m) true_size++simpleTestM :: MonadGen m => m (TestM Int)+simpleTestM = genTestM (Gen.integral $ Range.constant 0 5)++listToQueue :: [a] -> Queue a+listToQueue = foldl' (S.|>) S.empty++genViewSized :: forall m a. MonadGen m => m a -> Size -> m (ViewT TestM a)+genViewSized _ sz | sz <= 1 = pure Empty+genViewSized m sz = do+ a <- m+ s <- genSeqTSized m (sz - 1)+ pure (a :< s)++genSeqTSized :: forall m a. MonadGen m => m a -> Size -> m (SeqT TestM a)+genSeqTSized m sz = do+ part <- splat sz+ goop <- traverse (genTestMSized (genViewSized m)) part+ pure $ SeqT $ listToQueue goop++genSeqT :: forall m a. MonadGen m => m a -> m (SeqT TestM a)+genSeqT m = Gen.sized $ \sz -> do+ tsz <- Gen.integral (Range.linear 0 sz)+ genSeqTSized m tsz++simpleSeqT :: MonadGen m => m (SeqT TestM Int)+simpleSeqT = genSeqT (Gen.integral $ Range.constant 0 5)++genSeqSized :: forall m a. MonadGen m => m a -> Size -> m (Seq a)+genSeqSized m sz = do+ part <- splat sz+ goop <- traverse (fmap Identity <$> genViewSizedId m) part+ pure $ SeqT $ listToQueue goop++genViewSizedId :: forall m a. MonadGen m => m a -> Size -> m (ViewT Identity a)+genViewSizedId _ sz | sz <= 1 = pure Empty+genViewSizedId m sz = do+ a <- m+ s <- genSeqSized m (sz - 1)+ pure (a :< s)++genSeq :: forall m a. MonadGen m => m a -> m (Seq a)+genSeq m = Gen.sized $ \sz -> do+ tsz <- Gen.integral (Range.linear 0 sz)+ genSeqSized m tsz++simpleSeq :: MonadGen m => m (Seq Int)+simpleSeq = genSeq (Gen.integral $ Range.constant 0 5)++main :: IO ()+main = hspec $ do+ describe "observe" $ do+ it "undoes pure" $ hedgehog $+ observe (pure (3 :: Int)) === Just 3+ describe "observeT" $ do+ it "undoes lift" $ hedgehog $ do+ ex <- forAll simpleTestM+ observeT (lift ex) === (Just <$> ex)+ describe "observeAllT" $ do+ it "undoes lift" $ hedgehog $ do+ ex <- forAll simpleTestM+ observeAllT (lift ex) === fmap (:[]) ex+ it "works like logicT" $ hedgehog $ do+ ex <- forAll simpleSeqT+ observeAllT ex === L.observeAllT (Compat.fromSeqT ex)+ describe "observeManyT" $ do+ it "takes at most n" $ hedgehog $ do+ n <- forAll $ Gen.integral (Range.linearFrom 0 (-100) 100)+ let alot :: SeqT (ST s) Int+ alot = pure n <|> alot+ length (runST (observeManyT n alot)) === max 0 n+ it "takes what it can" $ hedgehog $ do+ n <- forAll $ Gen.integral (Range.linearFrom 0 0 100)+ k <- forAll $ Gen.integral (Range.linearFrom 0 0 10)+ let alot :: Int -> SeqT (ST s) Int+ alot x | x <= 0 = empty+ alot x = pure x <|> alot (x-1)+ length (runST (observeManyT n (alot (n-k)))) === max 0 (n-k)+ it "in order" $ hedgehog $ do+ n <- forAll $ Gen.integral (Range.linearFrom 0 0 100)+ let alot :: Int -> SeqT (ST s) Int+ alot x | x <= 0 = empty+ alot x = pure x <|> alot (x-1)+ runST (observeManyT n (alot n)) === [n,(n-1)..1]+ describe "observeMany" $ do+ it "takes at most n" $ hedgehog $ do+ n <- forAll $ Gen.integral (Range.linearFrom 0 (-100) 100)+ let alot :: Seq Int+ alot = pure n <|> alot+ length (observeMany n alot) === max 0 n+ it "takes what it can" $ hedgehog $ do+ n <- forAll $ Gen.integral (Range.linearFrom 0 0 100)+ k <- forAll $ Gen.integral (Range.linearFrom 0 0 10)+ let alot :: Int -> Seq Int+ alot x | x <= 0 = empty+ alot x = pure x <|> alot (x-1)+ length (observeMany n (alot (n-k))) === max 0 (n-k)+ it "in order" $ hedgehog $ do+ n <- forAll $ Gen.integral (Range.linearFrom 0 0 100)+ let alot :: Int -> Seq Int+ alot x | x <= 0 = empty+ alot x = pure x <|> alot (x-1)+ observeMany n (alot n) === [n,(n-1)..1]+ describe "read" $ do+ it "undoes show" $ hedgehog $ do+ ex <- forAll simpleSeqT+ readMaybe (show ex) === Just ex+ describe ">>=" $ do+ it "obeys monad identity law 1" $ hedgehog $ do+ s <- forAll simpleSeqT+ (s >>= return) === s+ it "obeys monad identity law 2" $ hedgehog $ do+ a <- forAll $ Gen.integral Range.linearBounded+ f :: Int -> SeqT TestM Int <- Fun.forAllFn (Fun.fn simpleSeqT)+ (pure a >>= f) === f a+ it "works like LogicT" $ hedgehog $ do+ s <- forAll simpleSeqT+ f :: Int -> SeqT TestM Int <- Fun.forAllFn (Fun.fn simpleSeqT)+ Compat.fromLogicT (Compat.toLogicT s >>= Compat.toLogicT . f) === (s >>= f)+ it "obeys monad associativity law" $ hedgehog $ do+ s <- forAll simpleSeqT+ f :: Int -> SeqT TestM Int <- Fun.forAllFn (Fun.fn simpleSeqT)+ g :: Int -> SeqT TestM Int <- Fun.forAllFn (Fun.fn simpleSeqT)+ ((s >>= f) >>= g) === (s >>= \a -> f a >>= g)+ it "obeys left zero law" $ hedgehog $ do+ f :: Int -> SeqT TestM Int <- Fun.forAllFn (Fun.fn simpleSeqT)+ (empty >>= f) === empty+ describe "<|>" $ do+ it "is associative" $ hedgehog $ do+ s <- forAll (Gen.small simpleSeqT)+ t <- forAll (Gen.small simpleSeqT)+ u <- forAll (Gen.small simpleSeqT)+ ((s <|> t) <|> u) === (s <|> (t <|> u))+ it "obeys Alternative identity laws" $ hedgehog $ do+ s <- forAll (Gen.small simpleSeqT)+ (s <|> empty) === s+ (empty <|> s) === s+ it "obeys left distribution" $ hedgehog $ do+ s <- forAll (Gen.small simpleSeqT)+ t <- forAll (Gen.small simpleSeqT)+ f :: Int -> SeqT TestM Int <- Fun.forAllFn (Fun.fn simpleSeqT)+ ((s <|> t) >>= f) === ((s >>= f) <|> (t >>= f))+ it "works like LogicT" $ hedgehog $ do+ s <- forAll simpleSeqT+ t <- forAll simpleSeqT+ (s <|> t) === Compat.fromLogicT (Compat.fromSeqT s <|> Compat.fromSeqT t)++ describe "fromLogicT" $ do+ it "reverses fromSeqT" $ hedgehog $ do+ s <- forAll simpleSeqT+ Compat.fromLogicT (Compat.fromSeqT s) === s++ describe "fromViewT" $ do+ it "reverses toViewT" $ hedgehog $ do+ s <- forAll simpleSeqT+ fromViewT (toViewT s) === s++ describe "MonadReader instance" $ do+ it "passes the tests in https://github.com/Bodigrim/logict/issues/1" $ do+ runReader (runMaybeT (observeAllT (local (5+) ask))) 0 `shouldBe` Just [5]+ let+ foo :: MonadReader Int m => m (Int, Int)+ foo = do+ x <- local (5+) ask+ y <- ask+ return (x, y)+ runReader (observeT foo) 0 `shouldBe` Just (5, 0)++ describe "MFunctor instance" $ do+ it "obeys the hoist identity law" $ hedgehog $ do+ s <- forAll simpleSeqT+ hoist (\x -> x) s === s++ describe "MonadTrans instance" $ do+ it "obeys the pure/lift law" $ hedgehog $ do+ a <- forAll (Gen.integral (Range.constant 0 10000))+ (lift (pure a) :: SeqT TestM Int) === pure a+ it "obeys the >>=/lift law" $ hedgehog $ do+ m <- forAll simpleTestM+ f :: Int -> TestM Int <- Fun.forAllFn (Fun.fn simpleTestM)+ (lift m >>= lift . f :: SeqT TestM Int) === lift (m >>= f)++ describe "msplit" $ do+ it "obeys msplit empty law" $+ L.msplit (empty :: SeqT TestM Int) `shouldBe` pure Nothing+ it "obeys msplit of cons law" $+ hedgehog $ do+ a <- forAll (Gen.integral (Range.constant 0 10000))+ m <- forAll simpleSeqT+ L.msplit (pure a <|> m) === pure (Just (a, m))++ describe "interleave" $ do+ it "behaves as documented on examples" $ do+ let x = choose [1,2,3]+ y = choose [4,5,6]+ z = choose [7,8,9] :: Seq Int+ observeAll (x `L.interleave` y) `shouldBe` [1,4,2,5,3,6]+ observeAll ((x `L.interleave` y) `L.interleave` z) `shouldBe` [1,7,4,8,2,9,5,3,6]+ observeAll (y `L.interleave` z) `shouldBe` [4,7,5,8,6,9]+ observeAll (x `L.interleave` (y `L.interleave` z)) `shouldBe` [1,4,2,7,3,5,8,6,9]++ describe ">>-" $ do+ it "behaves as documented in class documentation examples" $ do+ let+ odds :: Seq Int+ odds = pure 1 <|> fmap (2 +) odds+ oddsPlus n = odds >>= \a -> pure (a + n)+ q = do+ x <- (pure 0 <|> pure 1) L.>>- oddsPlus+ if even x then pure x else empty+ observeMany 3 q `shouldBe` [2,4,6]+ let+ m = choose [2,7 :: Int]+ k x = choose [x, x + 1]+ h x = choose [x, x * 2]+ observeAll (m >>= (\x -> k x >>= h))+ `shouldBe` [2,4,3,6,7,14,8,16]+ observeAll ((m >>= k) >>= h)+ `shouldBe` [2,4,3,6,7,14,8,16]+ observeAll (m >>- (\x -> k x >>- h))+ `shouldBe` [2,7,3,8,4,14,6,16]+ observeAll ((m >>- k) >>- h)+ `shouldBe` [2,7,4,3,14,8,6,16]+ let booyakasha = (pure (0 :: Int) <|> pure 1) >>-+ oddsPlus >>-+ \x -> if even x then pure x else empty+ observeMany 10 booyakasha `shouldBe` [2,4,6,8,10,12,14,16,18,20]++ describe "once" $ do+ it "behaves as documented in class documentation example" $ do+ let+ divisors n = do a <- choose [2..n-1]+ b <- choose [2..n-1]+ guard (a * b == n)+ pure (a, b)+ composite v = "Composite" <$ once (divisors v)+ observeAll (composite 20) `shouldBe` ["Composite"]++ describe "lnot" $ do+ it "behaves as documented in class documentation example" $ do+ let+ divisors n = do d <- choose [2..n-1]+ guard (n `rem` d == 0)+ pure d++ prime v = do _ <- lnot (divisors v)+ pure True+ observeAll (prime 20) `shouldBe` []+ observeAll (prime 19) `shouldBe` [True]++ describe "ifte" $ do+ it "obeys the law ifte (pure a) th el == th a" $ hedgehog $ do+ a <- forAll (Gen.integral (Range.constant 0 10000))+ th :: Int -> SeqT TestM Int <- Fun.forAllFn (Fun.fn simpleSeqT)+ let el = error "Should not reach el"+ ifte (pure a) th el === th a++ it "obeys the law ifte empty th el == el" $ hedgehog $ do+ let th = error "Should not reach th"+ el <- forAll simpleSeqT+ ifte empty th el === el++ it "obeys the law ifte (pure a <|> m) th el == th a <|> (m >>= th)" $ hedgehog $ do+ a <- forAll (Gen.integral (Range.constant 0 10000))+ m <- forAll (Gen.small simpleSeqT)+ th :: Int -> SeqT TestM Int <- Fun.forAllFn (Fun.fn simpleSeqT)+ let el = error "Should not reach el"+ (ifte (pure a <|> m) th el) === (th a <|> (m >>= th))++ it "behaves as documented in class documentation example" $ do+ -- Note: at the moment (logict-0.7.1.0) this example is actually+ -- written wrong. It's corrected below, and will be fixed upstream+ -- in the next version.+ let+ divisors n = do d <- choose [2..n-1]+ guard (n `rem` d == 0)+ pure d+ prime v = once (ifte (divisors v)+ (const (pure False))+ (pure True))+ observeAll (prime 20) `shouldBe` [False]+ observeAll (prime 19) `shouldBe` [True]++ describe "cons" $ do+ it "works as documented" $ hedgehog $ do+ a <- forAll (Gen.integral (Range.constant 0 10000))+ s <- forAll simpleSeqT+ cons a s === (pure a <|> s)+ describe "consM" $ do+ it "works as documented" $ hedgehog $ do+ ma <- forAll simpleTestM+ s <- forAll simpleSeqT+ consM ma s === (lift ma <|> s)+ describe "choose" $ do+ it "works as documented" $ hedgehog $ do+ lst <- forAll $ Gen.list (Range.linear 0 10) (Gen.int (Range.constant 0 10000))+ choose lst === foldr (\a s -> pure a <|> s) (empty :: SeqT TestM Int) lst+ it "works on infinite lists" $+ observeManyT 4 (choose [1 ..] :: SeqT TestM Integer) `shouldBe` pure [1,2,3,4]+ describe "chooseM" $ do+ it "works as documented" $ hedgehog $ do+ lst <- forAll $ Gen.list (Range.linear 0 5) (Gen.small simpleTestM)+ chooseM lst === foldr (\ma s -> lift ma <|> s) (empty :: SeqT TestM Int) lst+ it "works on infinite lists" $ do+ let lst = cycle [[3,4],[5],[6,7]] :: [[Int]]+ (shouldBe `on` observeManyT 4)+ (chooseM lst)+ (foldr (\ma s -> lift ma <|> s) empty lst)++ describe "foldMap" $ do+ it "works like LogicT" $ hedgehog $ do+ s <- forAll simpleSeqT+ f :: Int -> [Int] <- Fun.forAllFn (Fun.fn (Gen.list (Range.linear 0 5) (Gen.int (Range.constant 0 10000))))+ foldMap f s === foldMap f (Compat.toLogicT s)++ describe "traverse" $ do+ it "works like LogicT" $ hedgehog $ do+ s <- forAll simpleSeq+ f :: Int -> Identity Int <- (Identity .) <$> Fun.forAllFn (Fun.fn (Gen.int (Range.constant 0 10000)))+ traverse f s === (Compat.fromLogicT <$> traverse f (Compat.toLogicT s))++-- -------+-- Reimplementation of Control.Monad.Free without the need+-- to futz with Data.Functor.Classes.++data Free f a = Pure a | Free (f (Free f a))+ deriving (Functor, Foldable, Traversable)+deriving instance (Show a, Show (f (Free f a))) => Show (Free f a)+deriving instance (Read a, Read (f (Free f a))) => Read (Free f a)+deriving instance (Eq a, Eq (f (Free f a))) => Eq (Free f a)+instance Functor f => Applicative (Free f) where+ pure = Pure+ (<*>) = ap+instance Functor f => Monad (Free f) where+ Pure a >>= f = f a+ Free ffa >>= f = Free $ (>>= f) <$> ffa
+ test/do-nothing.hs view
@@ -0,0 +1,4 @@+module Main(main) where++main :: IO ()+main = return ()