packages feed

logicst (empty) → 0.1.0.0

raw patch · 8 files changed

+494/−0 lines, 8 filesdep +basedep +logictdep +transformerssetup-changed

Dependencies added: base, logict, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Andy Sonnenburg++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Andy Sonnenburg nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell+> module Main (main) where++> import Distribution.Simple (defaultMain)++> main :: IO ()+> main = defaultMain
+ logicst.cabal view
@@ -0,0 +1,39 @@+name:                logicst+version:             0.1.0.0+synopsis:            Backtracking mutable references in the ST and IO monads+description:         Backtracking mutable references in the ST and IO monads+license:             BSD3+license-file:        LICENSE+author:              Andy Sonnenburg+maintainer:          Andy Sonnenburg <andy22286@gmail.com>+homepage:            http://github.com/sonyandy/logicst+bug-reports:         http://github.com/sonyandy/logicst/issues+copyright:           Copyright (C) 2013 Andy Sonnenburg+category:            Control+build-type:          Simple+cabal-version:       >= 1.6++source-repository head+  type: git+  location: git://github.com/sonyandy/logicst.git++flag safe-st+flag old-applicative++library+  hs-source-dirs: src+  exposed-modules:+    Control.Monad.IO.Logic+    Control.Monad.ST.Logic+    Control.Monad.ST.Logic.Internal+    Data.IORef.Logic+    Data.STRef.Logic+  if flag(safe-st)+    build-depends: base >= 4.4+    cpp-options: -DMODULE_Control_Monad_ST_Safe+  if flag(old-applicative)+    build-depends: base < 4.2+    cpp-options: -DCLASS_OldApplicative+  build-depends: base >= 4 && < 5, transformers, logict+  other-extensions: CPP, Rank2Types, TypeFamilies+  ghc-options: -Wall -fwarn-tabs -O2
+ src/Control/Monad/IO/Logic.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE CPP, Rank2Types #-}+module Control.Monad.IO.Logic+       ( LogicIO+       , runLogicIO+       , observeIO+       , observeAllIO+       , observeManyIO+       , liftST+       ) where++#ifdef MODULE_Control_Monad_ST_Safe+import Control.Monad.ST.Safe+#else+import Control.Monad.ST+#endif+import Control.Monad.ST.Logic.Internal hiding (liftST)+import qualified Control.Monad.ST.Logic.Internal as Internal++type LogicIO s = LogicT s IO++runLogicIO :: (forall s . LogicIO s a) -> (a -> IO r -> IO r) -> IO r -> IO r+runLogicIO = runLogicT+{-# INLINE runLogicIO #-}++observeIO :: (forall s . LogicIO s a) -> IO a+observeIO = observeT+{-# INLINE observeIO #-}++observeAllIO :: (forall s . LogicIO s a) -> IO [a]+observeAllIO = observeAllT+{-# INLINE observeAllIO #-}++observeManyIO :: Int -> (forall s . LogicIO s a) -> IO [a]+observeManyIO = observeManyT+{-# INLINE observeManyIO #-}++liftST :: ST RealWorld a -> LogicIO s a+liftST = Internal.liftST+{-# INLINE liftST #-}
+ src/Control/Monad/ST/Logic.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE CPP, Rank2Types #-}+module Control.Monad.ST.Logic+       ( LogicST+       , runLogicST+       , observeST+       , observeAllST+       , observeManyST+       , liftST+       ) where++#ifdef MODULE_Control_Monad_ST_Safe+import Control.Monad.ST.Safe+#else+import Control.Monad.ST+#endif+import Control.Monad.ST.Logic.Internal (LogicT)+import qualified Control.Monad.ST.Logic.Internal as Internal++type LogicST s = LogicT s (ST s)++runLogicST :: (forall s . LogicST s a) -> (a -> r -> r) -> r -> r+runLogicST = Internal.runLogicST+{-# INLINE runLogicST #-}++observeST :: (forall s . LogicST s a) -> a+observeST = Internal.observeST+{-# INLINE observeST #-}++observeAllST :: (forall s . LogicST s a) -> [a]+observeAllST = Internal.observeAllST+{-# INLINE observeAllST #-}++observeManyST :: Int -> (forall s . LogicST s a) -> [a]+observeManyST = Internal.observeManyST+{-# INLINE observeManyST #-}++liftST :: ST s a -> LogicST s a+liftST = Internal.liftST+{-# INLINE liftST #-}
+ src/Control/Monad/ST/Logic/Internal.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE CPP, Rank2Types, TypeFamilies #-}+module Control.Monad.ST.Logic.Internal+       ( LogicT+       , runLogicT+       , observeT+       , observeAllT+       , observeManyT+       , liftST+       , runLogicST+       , observeST+       , observeAllST+       , observeManyST+       , Ref+       , newRef+       , readRef+       , writeRef+       , modifyRef+       , modifyRef'+       ) where++import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import qualified Control.Monad.Logic as Logic+import Control.Monad.Logic.Class+#ifdef MODULE_Control_Monad_ST_Safe+import Control.Monad.ST.Safe+#else+import Control.Monad.ST+#endif+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Strict (StateT, evalStateT)+import qualified Control.Monad.Trans.State.Strict as State++import qualified Data.STRef as ST++class Monad m => MonadST m where+  type World m+  liftST :: ST (World m) a -> m a++instance MonadST (ST s) where+  type World (ST s) = s+  liftST = id++instance MonadST IO where+  type World IO = RealWorld+  liftST = stToIO++newtype LogicT s m a =+  LogicT { unLogicT :: StateT (Switch m) (Logic.LogicT m) a+         }++runLogicT :: MonadST m => (forall s . LogicT s m a) -> (a -> m r -> m r) -> m r -> m r+runLogicT m = unsafeRunLogicT m+{-# INLINE runLogicT #-}++runLogicST :: (forall s . LogicT s (ST s) a) -> (a -> r -> r) -> r -> r+runLogicST m next zero = runST $ unsafeRunLogicT m (liftM . next) (return zero)+{-# INLINE runLogicST #-}++unsafeRunLogicT :: MonadST m => LogicT s m a -> (a -> m r -> m r) -> m r -> m r+unsafeRunLogicT m next zero = do+  s <- newSwitch+  Logic.runLogicT (evalStateT (unLogicT m) s) next zero+{-# SPECIALIZE unsafeRunLogicT :: LogicT s (ST s) a -> (a -> ST s r -> ST s r) -> ST s r -> ST s r #-}+{-# SPECIALIZE unsafeRunLogicT :: LogicT s IO a -> (a -> IO r -> IO r) -> IO r -> IO r #-}++observeT :: MonadST m => (forall s . LogicT s m a) -> m a+observeT m = unsafeObserveT m+{-# INLINE observeT #-}++observeST :: (forall s . LogicT s (ST s) a) -> a+observeST m = runST $ unsafeObserveT m+{-# INLINE observeST #-}++unsafeObserveT :: MonadST m => LogicT s m a -> m a+unsafeObserveT m = do+  s <- newSwitch+  Logic.observeT (evalStateT (unLogicT m) s)+{-# SPECIALIZE unsafeObserveT :: LogicT s (ST s) a -> ST s a #-}+{-# SPECIALIZE unsafeObserveT :: LogicT s IO a -> IO a #-}++observeAllT :: MonadST m => (forall s . LogicT s m a) -> m [a]+observeAllT m = unsafeObserveAllT m+{-# INLINE observeAllT #-}++observeAllST :: (forall s . LogicT s (ST s) a) -> [a]+observeAllST m = runST $ unsafeObserveAllT m+{-# INLINE observeAllST #-}++unsafeObserveAllT :: MonadST m => LogicT s m a -> m [a]+unsafeObserveAllT m = do+  s <- newSwitch+  Logic.observeAllT (evalStateT (unLogicT m) s)+{-# SPECIALIZE unsafeObserveAllT :: LogicT s (ST s) a -> ST s [a] #-}+{-# SPECIALIZE unsafeObserveAllT :: LogicT s IO a -> IO [a] #-}++observeManyT :: MonadST m => Int -> (forall s . LogicT s m a) -> m [a]+observeManyT n m = unsafeObserveManyT n m+{-# INLINE observeManyT #-}++observeManyST :: Int -> (forall s . LogicT s (ST s) a) -> [a]+observeManyST n m = runST $ unsafeObserveManyT n m+{-# INLINE observeManyST #-}++unsafeObserveManyT :: MonadST m => Int -> LogicT s m a -> m [a]+unsafeObserveManyT n m = do+  s <- newSwitch+  Logic.observeManyT n (evalStateT (unLogicT m) s)+{-# SPECIALIZE unsafeObserveManyT :: Int -> LogicT s (ST s) a -> ST s [a] #-}+{-# SPECIALIZE unsafeObserveManyT :: Int -> LogicT s IO a -> IO [a] #-}++instance Functor (LogicT s m) where+  fmap f = LogicT . fmap f . unLogicT+  {-# INLINE fmap #-}++instance Applicative (LogicT s m) where+  pure = LogicT . pure+  {-# INLINE pure #-}+  f <*> a = LogicT $ unLogicT f <*> unLogicT a+  {-# INLINE (<*>) #-}+#ifndef CLASS_OldApplicative+  a *> b = LogicT $ unLogicT a *> unLogicT b+  {-# INLINE (*>) #-}+  a <* b = LogicT $ unLogicT a <* unLogicT b+  {-# INLINE (<*) #-}+#endif++instance MonadST m => Alternative (LogicT s m) where+  empty = LogicT empty+  {-# INLINE empty #-}+  (<|>) = plusLogic+  {-# INLINE (<|>) #-}++instance Monad (LogicT s m) where+  return = LogicT . return+  {-# INLINE return #-}+  m >>= k = LogicT $ unLogicT m >>= unLogicT . k+  {-# INLINE (>>=) #-}+  m >> n = LogicT $ unLogicT m >> unLogicT n+  {-# INLINE (>>) #-}+  fail = LogicT . fail+  {-# INLINE fail #-}++instance MonadST m => MonadPlus (LogicT s m) where+  mzero = LogicT mzero+  {-# INLINE mzero #-}+  mplus = plusLogic+  {-# INLINE mplus #-}++plusLogic :: MonadST m => LogicT s m a -> LogicT s m a -> LogicT s m a+plusLogic m n = do+  s <- newSwitch+  LogicT $ unLogicT (put s *> m) <|> unLogicT (flipSwitch s *> n)+{-# SPECIALIZE plusLogic :: LogicT s (ST s) a -> LogicT s (ST s) a -> LogicT s (ST s) a #-}+{-# SPECIALIZE plusLogic :: LogicT s IO a -> LogicT s IO a -> LogicT s IO a #-}++instance MonadST m => MonadLogic (LogicT s m) where+  msplit = LogicT . fmap (fmap (fmap LogicT)) . msplit . unLogicT+  {-# INLINE msplit #-}++liftLogic :: Monad m => m a -> LogicT s m a+liftLogic = LogicT . lift . lift+{-# SPECIALIZE liftLogic :: ST s a -> LogicT s (ST s) a #-}+{-# SPECIALIZE liftLogic :: IO a -> LogicT s IO a #-}++instance MonadIO m => MonadIO (LogicT s m) where+  liftIO = liftLogic . liftIO++instance MonadST m => MonadST (LogicT s m) where+  type World (LogicT s m) = World m+  liftST = liftLogic . liftST+  {-# INLINE liftST #-}++get :: Monad m => LogicT s m (Switch m)+get = LogicT State.get+{-# SPECIALIZE get :: LogicT s (ST s) (Switch (ST s)) #-}+{-# SPECIALIZE get :: LogicT s IO (Switch IO) #-}++put :: Monad m => Switch m -> LogicT s m ()+put s = s `seq` LogicT (State.put s)+{-# SPECIALIZE put :: Switch (ST s) -> LogicT s (ST s) () #-}+{-# SPECIALIZE put :: Switch IO -> LogicT s IO () #-}++type Switch m = ST.STRef (World m) Bool++newSwitch :: MonadST m => m (Switch m)+newSwitch = liftST $ ST.newSTRef False+{-# INLINE newSwitch #-}++flipSwitch :: MonadST m => Switch m -> m ()+flipSwitch = liftST . flip ST.writeSTRef True+{-# INLINE flipSwitch #-}++ifFlipped :: Switch (ST s) -> ST s a -> ST s a -> ST s a+ifFlipped switch t f = do+  p <- ST.readSTRef switch+  if p then t else f++newtype Ref s m a = Ref (ST.STRef (World m) (Value m a))++data Value m a+  = New {-# UNPACK #-} !(Write m a)+  | {-# UNPACK #-} !(Write m a) :| !(Value m a)++data Write m a = Write {-# UNPACK #-} !(Switch m) a++newRef :: MonadST m => a -> LogicT s m (Ref s m a)+newRef a = get >>= liftST . fmap Ref . newSTRef a+{-# SPECIALIZE newRef :: a -> LogicT s (ST s) (Ref s (ST s) a) #-}+{-# SPECIALIZE newRef :: a -> LogicT s IO (Ref s IO a) #-}++newSTRef :: a -> Switch m -> ST (World m) (ST.STRef (World m) (Value m a))+newSTRef a = ST.newSTRef .! New . flip Write a++infixr 9 .!+(.!) :: (b -> c) -> (a -> b) -> a -> c+f .! g = \ a -> a `seq` f (g a)++readRef :: MonadST m => Ref s m a -> LogicT s m a+readRef (Ref ref) = liftST $ readSTRef ref+{-# SPECIALIZE readRef :: Ref s (ST s) a -> LogicT s (ST s) a #-}+{-# SPECIALIZE readRef :: Ref s IO a -> LogicT s IO a #-}++readSTRef :: ST.STRef (World m) (Value m a) -> ST (World m) a+readSTRef ref = ST.readSTRef ref >>= \ value -> case value of+  Write switch a :| xs -> ifFlipped switch (backtrack xs) $ return a+  New (Write _ a) -> return a+  where+    backtrack xs@(Write switch a :| ys) =+      ifFlipped switch (backtrack ys) $+      ST.writeSTRef ref xs >> return a+    backtrack xs@(New (Write _ a)) =+      ST.writeSTRef ref xs >> return a++writeRef :: MonadST m => Ref s m a -> a -> LogicT s m ()+writeRef ref a = modifyRef'' ref $ \ switch _ -> Write switch a+{-# SPECIALIZE writeRef :: Ref s (ST s) a -> a -> LogicT s (ST s) () #-}+{-# SPECIALIZE writeRef :: Ref s IO a -> a -> LogicT s IO () #-}++modifyRef :: MonadST m => Ref s m a -> (a -> a) -> LogicT s m ()+modifyRef ref f = modifyRef'' ref $ \ switch a -> Write switch $ f a+{-# SPECIALIZE modifyRef :: Ref s (ST s) a -> (a -> a) -> LogicT s (ST s) () #-}+{-# SPECIALIZE modifyRef :: Ref s IO a -> (a -> a) -> LogicT s IO () #-}++modifyRef' :: MonadST m => Ref s m a -> (a -> a) -> LogicT s m ()+modifyRef' ref f = modifyRef'' ref $ \ switch a -> Write switch $! f a+{-# SPECIALIZE modifyRef' :: Ref s (ST s) a -> (a -> a) -> LogicT s (ST s) () #-}+{-# SPECIALIZE modifyRef' :: Ref s IO a -> (a -> a) -> LogicT s IO () #-}++modifyRef'' :: MonadST m => Ref s m a -> (Switch m -> a -> Write m a) -> LogicT s m ()+modifyRef'' (Ref ref) f = get >>= \ r -> liftST $ modifySTRef ref f r+{-# INLINE modifyRef'' #-}++modifySTRef :: ST.STRef (World m) (Value m a) ->+               (Switch m -> a -> Write m a) ->+               Switch m ->+               ST (World m) ()+modifySTRef ref f = \ r -> ST.readSTRef ref >>= \ value -> backtrack value r+  where+    backtrack xs@(Write switch a :| ys) r =+      ifFlipped switch+      (backtrack ys r)+      (ST.writeSTRef ref $! f r a :| if switch == r then ys else xs)+    backtrack xs@(New (Write switch a)) r =+      ST.writeSTRef ref $!+      if switch == r then New (f r a) else f r a :| xs+{-# INLINE modifySTRef #-}
+ src/Data/IORef/Logic.hs view
@@ -0,0 +1,33 @@+module Data.IORef.Logic+       ( IORef+       , newIORef+       , readIORef+       , writeIORef+       , modifyIORef+       , modifyIORef'+       ) where++import Control.Monad.IO.Logic+import Control.Monad.ST.Logic.Internal++type IORef s = Ref s IO++newIORef :: a -> LogicIO s (IORef s a)+newIORef = newRef+{-# INLINE newIORef #-}++readIORef :: IORef s a -> LogicIO s a+readIORef = readRef+{-# INLINE readIORef #-}++writeIORef :: IORef s a -> a -> LogicIO s ()+writeIORef = writeRef+{-# INLINE writeIORef #-}++modifyIORef :: IORef s a -> (a -> a) -> LogicIO s ()+modifyIORef = modifyRef+{-# INLINE modifyIORef #-}++modifyIORef' :: IORef s a -> (a -> a) -> LogicIO s ()+modifyIORef' = modifyRef'+{-# INLINE modifyIORef' #-}
+ src/Data/STRef/Logic.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE CPP #-}+module Data.STRef.Logic+       ( STRef+       , newSTRef+       , readSTRef+       , writeSTRef+       , modifySTRef+       , modifySTRef'+       ) where++#ifdef MODULE_Control_Monad_ST_Safe+import Control.Monad.ST.Safe+#else+import Control.Monad.ST+#endif+import Control.Monad.ST.Logic+import Control.Monad.ST.Logic.Internal++type STRef s = Ref s (ST s)++newSTRef :: a -> LogicST s (STRef s a)+newSTRef = newRef+{-# INLINE newSTRef #-}++readSTRef :: STRef s a -> LogicST s a+readSTRef = readRef+{-# INLINE readSTRef #-}++writeSTRef :: STRef s a -> a -> LogicST s ()+writeSTRef = writeRef+{-# INLINE writeSTRef #-}++modifySTRef :: STRef s a -> (a -> a) -> LogicST s ()+modifySTRef = modifyRef+{-# INLINE modifySTRef #-}++modifySTRef' :: STRef s a -> (a -> a) -> LogicST s ()+modifySTRef' = modifyRef'+{-# INLINE modifySTRef' #-}